pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Now far ahead the Road has gone,
  13  * And I must follow, if I can,
  14  * Pursuing it with eager feet,
  15  * Until it joins some larger way
  16  * Where many paths and errands meet.
  17  * And whither then?  I cannot say.
  18  */
  19
  20 /* This file contains control-oriented pp ("push/pop") functions that
  21  * execute the opcodes that make up a perl program. A typical pp function
  22  * expects to find its arguments on the stack, and usually pushes its
  23  * results onto the stack, hence the 'pp' terminology. Each OP structure
  24  * contains a pointer to the relevant pp_foo() function.
  25  *
  26  * Control-oriented means things like pp_enteriter() and pp_next(), which
  27  * alter the flow of control of the program.
  28  */
  29
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_PP_CTL_C
  33 #include "perl.h"
  34
  35 #ifndef WORD_ALIGN
  36 #define WORD_ALIGN sizeof(U32)
  37 #endif
  38
  39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  40
  41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
  42
  43 PP(pp_wantarray)
  44 {
  45     dSP;
  46     I32 cxix;
  47     EXTEND(SP, 1);
  48
  49     cxix = dopoptosub(cxstack_ix);
  50     if (cxix < 0)
  51         RETPUSHUNDEF;
  52
  53     switch (cxstack[cxix].blk_gimme) {
  54     case G_ARRAY:
  55         RETPUSHYES;
  56     case G_SCALAR:
  57         RETPUSHNO;
  58     default:
  59         RETPUSHUNDEF;
  60     }
  61 }
  62
  63 PP(pp_regcmaybe)
  64 {
  65     return NORMAL;
  66 }
  67
  68 PP(pp_regcreset)
  69 {
  70     /* XXXX Should store the old value to allow for tie/overload - and
  71        restore in regcomp, where marked with XXXX. */
  72     PL_reginterp_cnt = 0;
  73     TAINT_NOT;
  74     return NORMAL;
  75 }
  76
  77 PP(pp_regcomp)
  78 {
  79     dSP;
  80     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     SV *tmpstr;
  82     MAGIC *mg = Null(MAGIC*);
  83
  84     /* prevent recompiling under /o and ithreads. */
  85 #if defined(USE_ITHREADS)
  86     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  87         if (PL_op->op_flags & OPf_STACKED) {
  88             dMARK;
  89             SP = MARK;
  90         }
  91         else
  92             (void)POPs;
  93         RETURN;
  94     }
  95 #endif
  96     if (PL_op->op_flags & OPf_STACKED) {
  97         /* multiple args; concatentate them */
  98         dMARK; dORIGMARK;
  99         tmpstr = PAD_SV(ARGTARG);
 100         sv_setpvn(tmpstr, "", 0);
 101         while (++MARK <= SP) {
 102             if (PL_amagic_generation) {
 103                 SV *sv;
 104                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
 105                     (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
 106                 {
 107                    sv_setsv(tmpstr, sv);
 108                    continue;
 109                 }
 110             }
 111             sv_catsv(tmpstr, *MARK);
 112         }
 113         SvSETMAGIC(tmpstr);
 114         SP = ORIGMARK;
 115     }
 116     else
 117         tmpstr = POPs;
 118
 119     if (SvROK(tmpstr)) {
 120         SV *sv = SvRV(tmpstr);
 121         if(SvMAGICAL(sv))
 122             mg = mg_find(sv, PERL_MAGIC_qr);
 123     }
 124     if (mg) {
 125         regexp *re = (regexp *)mg->mg_obj;
 126         ReREFCNT_dec(PM_GETRE(pm));
 127         PM_SETRE(pm, ReREFCNT_inc(re));
 128     }
 129     else {
 130         STRLEN len;
 131         const char *t = SvPV_const(tmpstr, len);
 132
 133         /* Check against the last compiled regexp. */
 134         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
 135             PM_GETRE(pm)->prelen != (I32)len ||
 136             memNE(PM_GETRE(pm)->precomp, t, len))
 137         {
 138             if (PM_GETRE(pm)) {
 139                 ReREFCNT_dec(PM_GETRE(pm));
 140                 PM_SETRE(pm, Null(REGEXP*));    /* crucial if regcomp aborts */
 141             }
 142             if (PL_op->op_flags & OPf_SPECIAL)
 143                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 144
 145             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 146             if (DO_UTF8(tmpstr))
 147                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
 148             else {
 149                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
 150                 if (pm->op_pmdynflags & PMdf_UTF8)
 151                     t = (char*)bytes_to_utf8((U8*)t, &len);
 152             }
 153             PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
 154             if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
 155                 Safefree(t);
 156             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 157                                            inside tie/overload accessors.  */
 158         }
 159     }
 160
 161 #ifndef INCOMPLETE_TAINTS
 162     if (PL_tainting) {
 163         if (PL_tainted)
 164             pm->op_pmdynflags |= PMdf_TAINTED;
 165         else
 166             pm->op_pmdynflags &= ~PMdf_TAINTED;
 167     }
 168 #endif
 169
 170     if (!PM_GETRE(pm)->prelen && PL_curpm)
 171         pm = PL_curpm;
 172     else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
 173         pm->op_pmflags |= PMf_WHITE;
 174     else
 175         pm->op_pmflags &= ~PMf_WHITE;
 176
 177     /* XXX runtime compiled output needs to move to the pad */
 178     if (pm->op_pmflags & PMf_KEEP) {
 179         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 180 #if !defined(USE_ITHREADS)
 181         /* XXX can't change the optree at runtime either */
 182         cLOGOP->op_first->op_next = PL_op->op_next;
 183 #endif
 184     }
 185     RETURN;
 186 }
 187
 188 PP(pp_substcont)
 189 {
 190     dSP;
 191     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 192     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 193     register SV * const dstr = cx->sb_dstr;
 194     register char *s = cx->sb_s;
 195     register char *m = cx->sb_m;
 196     char *orig = cx->sb_orig;
 197     register REGEXP * const rx = cx->sb_rx;
 198     SV *nsv = Nullsv;
 199     REGEXP *old = PM_GETRE(pm);
 200     if(old != rx) {
 201         if(old)
 202             ReREFCNT_dec(old);
 203         PM_SETRE(pm,rx);
 204     }
 205
 206     rxres_restore(&cx->sb_rxres, rx);
 207     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 208
 209     if (cx->sb_iters++) {
 210         const I32 saviters = cx->sb_iters;
 211         if (cx->sb_iters > cx->sb_maxiters)
 212             DIE(aTHX_ "Substitution loop");
 213
 214         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 215             cx->sb_rxtainted |= 2;
 216         sv_catsv(dstr, POPs);
 217
 218         /* Are we done */
 219         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 220                                      s == m, cx->sb_targ, NULL,
 221                                      ((cx->sb_rflags & REXEC_COPY_STR)
 222                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 223                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 224         {
 225             SV *targ = cx->sb_targ;
 226
 227             assert(cx->sb_strend >= s);
 228             if(cx->sb_strend > s) {
 229                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 230                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 231                  else
 232                       sv_catpvn(dstr, s, cx->sb_strend - s);
 233             }
 234             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 235
 236 #ifdef PERL_OLD_COPY_ON_WRITE
 237             if (SvIsCOW(targ)) {
 238                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 239             } else
 240 #endif
 241             {
 242                 SvPV_free(targ);
 243             }
 244             SvPV_set(targ, SvPVX(dstr));
 245             SvCUR_set(targ, SvCUR(dstr));
 246             SvLEN_set(targ, SvLEN(dstr));
 247             if (DO_UTF8(dstr))
 248                 SvUTF8_on(targ);
 249             SvPV_set(dstr, (char*)0);
 250             sv_free(dstr);
 251
 252             TAINT_IF(cx->sb_rxtainted & 1);
 253             PUSHs(sv_2mortal(newSViv(saviters - 1)));
 254
 255             (void)SvPOK_only_UTF8(targ);
 256             TAINT_IF(cx->sb_rxtainted);
 257             SvSETMAGIC(targ);
 258             SvTAINT(targ);
 259
 260             LEAVE_SCOPE(cx->sb_oldsave);
 261             ReREFCNT_dec(rx);
 262             POPSUBST(cx);
 263             RETURNOP(pm->op_next);
 264         }
 265         cx->sb_iters = saviters;
 266     }
 267     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 268         m = s;
 269         s = orig;
 270         cx->sb_orig = orig = rx->subbeg;
 271         s = orig + (m - s);
 272         cx->sb_strend = s + (cx->sb_strend - m);
 273     }
 274     cx->sb_m = m = rx->startp[0] + orig;
 275     if (m > s) {
 276         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 277             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 278         else
 279             sv_catpvn(dstr, s, m-s);
 280     }
 281     cx->sb_s = rx->endp[0] + orig;
 282     { /* Update the pos() information. */
 283         SV *sv = cx->sb_targ;
 284         MAGIC *mg;
 285         I32 i;
 286         if (SvTYPE(sv) < SVt_PVMG)
 287             SvUPGRADE(sv, SVt_PVMG);
 288         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 289             sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 290             mg = mg_find(sv, PERL_MAGIC_regex_global);
 291         }
 292         i = m - orig;
 293         if (DO_UTF8(sv))
 294             sv_pos_b2u(sv, &i);
 295         mg->mg_len = i;
 296     }
 297     if (old != rx)
 298         (void)ReREFCNT_inc(rx);
 299     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 300     rxres_save(&cx->sb_rxres, rx);
 301     RETURNOP(pm->op_pmreplstart);
 302 }
 303
 304 void
 305 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 306 {
 307     UV *p = (UV*)*rsp;
 308     U32 i;
 309
 310     if (!p || p[1] < rx->nparens) {
 311 #ifdef PERL_OLD_COPY_ON_WRITE
 312         i = 7 + rx->nparens * 2;
 313 #else
 314         i = 6 + rx->nparens * 2;
 315 #endif
 316         if (!p)
 317             Newx(p, i, UV);
 318         else
 319             Renew(p, i, UV);
 320         *rsp = (void*)p;
 321     }
 322
 323     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
 324     RX_MATCH_COPIED_off(rx);
 325
 326 #ifdef PERL_OLD_COPY_ON_WRITE
 327     *p++ = PTR2UV(rx->saved_copy);
 328     rx->saved_copy = Nullsv;
 329 #endif
 330
 331     *p++ = rx->nparens;
 332
 333     *p++ = PTR2UV(rx->subbeg);
 334     *p++ = (UV)rx->sublen;
 335     for (i = 0; i <= rx->nparens; ++i) {
 336         *p++ = (UV)rx->startp[i];
 337         *p++ = (UV)rx->endp[i];
 338     }
 339 }
 340
 341 void
 342 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 343 {
 344     UV *p = (UV*)*rsp;
 345     U32 i;
 346
 347     RX_MATCH_COPY_FREE(rx);
 348     RX_MATCH_COPIED_set(rx, *p);
 349     *p++ = 0;
 350
 351 #ifdef PERL_OLD_COPY_ON_WRITE
 352     if (rx->saved_copy)
 353         SvREFCNT_dec (rx->saved_copy);
 354     rx->saved_copy = INT2PTR(SV*,*p);
 355     *p++ = 0;
 356 #endif
 357
 358     rx->nparens = *p++;
 359
 360     rx->subbeg = INT2PTR(char*,*p++);
 361     rx->sublen = (I32)(*p++);
 362     for (i = 0; i <= rx->nparens; ++i) {
 363         rx->startp[i] = (I32)(*p++);
 364         rx->endp[i] = (I32)(*p++);
 365     }
 366 }
 367
 368 void
 369 Perl_rxres_free(pTHX_ void **rsp)
 370 {
 371     UV *p = (UV*)*rsp;
 372
 373     if (p) {
 374 #ifdef PERL_POISON
 375         void *tmp = INT2PTR(char*,*p);
 376         Safefree(tmp);
 377         if (*p)
 378             Poison(*p, 1, sizeof(*p));
 379 #else
 380         Safefree(INT2PTR(char*,*p));
 381 #endif
 382 #ifdef PERL_OLD_COPY_ON_WRITE
 383         if (p[1]) {
 384             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 385         }
 386 #endif
 387         Safefree(p);
 388         *rsp = Null(void*);
 389     }
 390 }
 391
 392 PP(pp_formline)
 393 {
 394     dSP; dMARK; dORIGMARK;
 395     register SV *tmpForm = *++MARK;
 396     register U32 *fpc;
 397     register char *t;
 398     const char *f;
 399     register I32 arg;
 400     register SV *sv = Nullsv;
 401     const char *item = Nullch;
 402     I32 itemsize  = 0;
 403     I32 fieldsize = 0;
 404     I32 lines = 0;
 405     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 406     const char *chophere = Nullch;
 407     char *linemark = Nullch;
 408     NV value;
 409     bool gotsome = FALSE;
 410     STRLEN len;
 411     STRLEN fudge = SvPOK(tmpForm)
 412                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 413     bool item_is_utf8 = FALSE;
 414     bool targ_is_utf8 = FALSE;
 415     SV * nsv = Nullsv;
 416     OP * parseres = 0;
 417     const char *fmt;
 418     bool oneline;
 419
 420     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 421         if (SvREADONLY(tmpForm)) {
 422             SvREADONLY_off(tmpForm);
 423             parseres = doparseform(tmpForm);
 424             SvREADONLY_on(tmpForm);
 425         }
 426         else
 427             parseres = doparseform(tmpForm);
 428         if (parseres)
 429             return parseres;
 430     }
 431     SvPV_force(PL_formtarget, len);
 432     if (DO_UTF8(PL_formtarget))
 433         targ_is_utf8 = TRUE;
 434     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 435     t += len;
 436     f = SvPV_const(tmpForm, len);
 437     /* need to jump to the next word */
 438     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 439
 440     for (;;) {
 441         DEBUG_f( {
 442             const char *name = "???";
 443             arg = -1;
 444             switch (*fpc) {
 445             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 446             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 447             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 448             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 449             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 450
 451             case FF_CHECKNL:    name = "CHECKNL";       break;
 452             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 453             case FF_SPACE:      name = "SPACE";         break;
 454             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 455             case FF_ITEM:       name = "ITEM";          break;
 456             case FF_CHOP:       name = "CHOP";          break;
 457             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 458             case FF_NEWLINE:    name = "NEWLINE";       break;
 459             case FF_MORE:       name = "MORE";          break;
 460             case FF_LINEMARK:   name = "LINEMARK";      break;
 461             case FF_END:        name = "END";           break;
 462             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 463             case FF_LINESNGL:   name = "LINESNGL";      break;
 464             }
 465             if (arg >= 0)
 466                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 467             else
 468                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 469         } );
 470         switch (*fpc++) {
 471         case FF_LINEMARK:
 472             linemark = t;
 473             lines++;
 474             gotsome = FALSE;
 475             break;
 476
 477         case FF_LITERAL:
 478             arg = *fpc++;
 479             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 480                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 481                 *t = '\0';
 482                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 483                 t = SvEND(PL_formtarget);
 484                 break;
 485             }
 486             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 487                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 488                 *t = '\0';
 489                 sv_utf8_upgrade(PL_formtarget);
 490                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 491                 t = SvEND(PL_formtarget);
 492                 targ_is_utf8 = TRUE;
 493             }
 494             while (arg--)
 495                 *t++ = *f++;
 496             break;
 497
 498         case FF_SKIP:
 499             f += *fpc++;
 500             break;
 501
 502         case FF_FETCH:
 503             arg = *fpc++;
 504             f += arg;
 505             fieldsize = arg;
 506
 507             if (MARK < SP)
 508                 sv = *++MARK;
 509             else {
 510                 sv = &PL_sv_no;
 511                 if (ckWARN(WARN_SYNTAX))
 512                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 513             }
 514             break;
 515
 516         case FF_CHECKNL:
 517             {
 518                 const char *send;
 519                 const char *s = item = SvPV_const(sv, len);
 520                 itemsize = len;
 521                 if (DO_UTF8(sv)) {
 522                     itemsize = sv_len_utf8(sv);
 523                     if (itemsize != (I32)len) {
 524                         I32 itembytes;
 525                         if (itemsize > fieldsize) {
 526                             itemsize = fieldsize;
 527                             itembytes = itemsize;
 528                             sv_pos_u2b(sv, &itembytes, 0);
 529                         }
 530                         else
 531                             itembytes = len;
 532                         send = chophere = s + itembytes;
 533                         while (s < send) {
 534                             if (*s & ~31)
 535                                 gotsome = TRUE;
 536                             else if (*s == '\n')
 537                                 break;
 538                             s++;
 539                         }
 540                         item_is_utf8 = TRUE;
 541                         itemsize = s - item;
 542                         sv_pos_b2u(sv, &itemsize);
 543                         break;
 544                     }
 545                 }
 546                 item_is_utf8 = FALSE;
 547                 if (itemsize > fieldsize)
 548                     itemsize = fieldsize;
 549                 send = chophere = s + itemsize;
 550                 while (s < send) {
 551                     if (*s & ~31)
 552                         gotsome = TRUE;
 553                     else if (*s == '\n')
 554                         break;
 555                     s++;
 556                 }
 557                 itemsize = s - item;
 558                 break;
 559             }
 560
 561         case FF_CHECKCHOP:
 562             {
 563                 const char *s = item = SvPV_const(sv, len);
 564                 itemsize = len;
 565                 if (DO_UTF8(sv)) {
 566                     itemsize = sv_len_utf8(sv);
 567                     if (itemsize != (I32)len) {
 568                         I32 itembytes;
 569                         if (itemsize <= fieldsize) {
 570                             const char *send = chophere = s + itemsize;
 571                             while (s < send) {
 572                                 if (*s == '\r') {
 573                                     itemsize = s - item;
 574                                     chophere = s;
 575                                     break;
 576                                 }
 577                                 if (*s++ & ~31)
 578                                     gotsome = TRUE;
 579                             }
 580                         }
 581                         else {
 582                             const char *send;
 583                             itemsize = fieldsize;
 584                             itembytes = itemsize;
 585                             sv_pos_u2b(sv, &itembytes, 0);
 586                             send = chophere = s + itembytes;
 587                             while (s < send || (s == send && isSPACE(*s))) {
 588                                 if (isSPACE(*s)) {
 589                                     if (chopspace)
 590                                         chophere = s;
 591                                     if (*s == '\r')
 592                                         break;
 593                                 }
 594                                 else {
 595                                     if (*s & ~31)
 596                                         gotsome = TRUE;
 597                                     if (strchr(PL_chopset, *s))
 598                                         chophere = s + 1;
 599                                 }
 600                                 s++;
 601                             }
 602                             itemsize = chophere - item;
 603                             sv_pos_b2u(sv, &itemsize);
 604                         }
 605                         item_is_utf8 = TRUE;
 606                         break;
 607                     }
 608                 }
 609                 item_is_utf8 = FALSE;
 610                 if (itemsize <= fieldsize) {
 611                     const char *const send = chophere = s + itemsize;
 612                     while (s < send) {
 613                         if (*s == '\r') {
 614                             itemsize = s - item;
 615                             chophere = s;
 616                             break;
 617                         }
 618                         if (*s++ & ~31)
 619                             gotsome = TRUE;
 620                     }
 621                 }
 622                 else {
 623                     const char *send;
 624                     itemsize = fieldsize;
 625                     send = chophere = s + itemsize;
 626                     while (s < send || (s == send && isSPACE(*s))) {
 627                         if (isSPACE(*s)) {
 628                             if (chopspace)
 629                                 chophere = s;
 630                             if (*s == '\r')
 631                                 break;
 632                         }
 633                         else {
 634                             if (*s & ~31)
 635                                 gotsome = TRUE;
 636                             if (strchr(PL_chopset, *s))
 637                                 chophere = s + 1;
 638                         }
 639                         s++;
 640                     }
 641                     itemsize = chophere - item;
 642                 }
 643                 break;
 644             }
 645
 646         case FF_SPACE:
 647             arg = fieldsize - itemsize;
 648             if (arg) {
 649                 fieldsize -= arg;
 650                 while (arg-- > 0)
 651                     *t++ = ' ';
 652             }
 653             break;
 654
 655         case FF_HALFSPACE:
 656             arg = fieldsize - itemsize;
 657             if (arg) {
 658                 arg /= 2;
 659                 fieldsize -= arg;
 660                 while (arg-- > 0)
 661                     *t++ = ' ';
 662             }
 663             break;
 664
 665         case FF_ITEM:
 666             {
 667                 const char *s = item;
 668                 arg = itemsize;
 669                 if (item_is_utf8) {
 670                     if (!targ_is_utf8) {
 671                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 672                         *t = '\0';
 673                         sv_utf8_upgrade(PL_formtarget);
 674                         SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 675                         t = SvEND(PL_formtarget);
 676                         targ_is_utf8 = TRUE;
 677                     }
 678                     while (arg--) {
 679                         if (UTF8_IS_CONTINUED(*s)) {
 680                             STRLEN skip = UTF8SKIP(s);
 681                             switch (skip) {
 682                             default:
 683                                 Move(s,t,skip,char);
 684                                 s += skip;
 685                                 t += skip;
 686                                 break;
 687                             case 7: *t++ = *s++;
 688                             case 6: *t++ = *s++;
 689                             case 5: *t++ = *s++;
 690                             case 4: *t++ = *s++;
 691                             case 3: *t++ = *s++;
 692                             case 2: *t++ = *s++;
 693                             case 1: *t++ = *s++;
 694                             }
 695                         }
 696                         else {
 697                             if ( !((*t++ = *s++) & ~31) )
 698                                 t[-1] = ' ';
 699                         }
 700                     }
 701                     break;
 702                 }
 703                 if (targ_is_utf8 && !item_is_utf8) {
 704                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 705                     *t = '\0';
 706                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 707                     for (; t < SvEND(PL_formtarget); t++) {
 708 #ifdef EBCDIC
 709                         const int ch = *t;
 710                         if (iscntrl(ch))
 711 #else
 712                             if (!(*t & ~31))
 713 #endif
 714                                 *t = ' ';
 715                     }
 716                     break;
 717                 }
 718                 while (arg--) {
 719 #ifdef EBCDIC
 720                     const int ch = *t++ = *s++;
 721                     if (iscntrl(ch))
 722 #else
 723                         if ( !((*t++ = *s++) & ~31) )
 724 #endif
 725                             t[-1] = ' ';
 726                 }
 727                 break;
 728             }
 729
 730         case FF_CHOP:
 731             {
 732                 const char *s = chophere;
 733                 if (chopspace) {
 734                     while (*s && isSPACE(*s))
 735                         s++;
 736                 }
 737                 sv_chop(sv,s);
 738                 SvSETMAGIC(sv);
 739                 break;
 740             }
 741
 742         case FF_LINESNGL:
 743             chopspace = 0;
 744             oneline = TRUE;
 745             goto ff_line;
 746         case FF_LINEGLOB:
 747             oneline = FALSE;
 748         ff_line:
 749             {
 750                 const char *s = item = SvPV_const(sv, len);
 751                 itemsize = len;
 752                 if ((item_is_utf8 = DO_UTF8(sv)))
 753                     itemsize = sv_len_utf8(sv);
 754                 if (itemsize) {
 755                     bool chopped = FALSE;
 756                     const char *const send = s + len;
 757                     gotsome = TRUE;
 758                     chophere = s + itemsize;
 759                     while (s < send) {
 760                         if (*s++ == '\n') {
 761                             if (oneline) {
 762                                 chopped = TRUE;
 763                                 chophere = s;
 764                                 break;
 765                             } else {
 766                                 if (s == send) {
 767                                     itemsize--;
 768                                     chopped = TRUE;
 769                                 } else
 770                                     lines++;
 771                             }
 772                         }
 773                     }
 774                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 775                     if (targ_is_utf8)
 776                         SvUTF8_on(PL_formtarget);
 777                     if (oneline) {
 778                         SvCUR_set(sv, chophere - item);
 779                         sv_catsv(PL_formtarget, sv);
 780                         SvCUR_set(sv, itemsize);
 781                     } else
 782                         sv_catsv(PL_formtarget, sv);
 783                     if (chopped)
 784                         SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
 785                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 786                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 787                     if (item_is_utf8)
 788                         targ_is_utf8 = TRUE;
 789                 }
 790                 break;
 791             }
 792
 793         case FF_0DECIMAL:
 794             arg = *fpc++;
 795 #if defined(USE_LONG_DOUBLE)
 796             fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
 797 #else
 798             fmt = (arg & 256) ? "%#0*.*f"              : "%0*.*f";
 799 #endif
 800             goto ff_dec;
 801         case FF_DECIMAL:
 802             arg = *fpc++;
 803 #if defined(USE_LONG_DOUBLE)
 804             fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
 805 #else
 806             fmt = (arg & 256) ? "%#*.*f"              : "%*.*f";
 807 #endif
 808         ff_dec:
 809             /* If the field is marked with ^ and the value is undefined,
 810                blank it out. */
 811             if ((arg & 512) && !SvOK(sv)) {
 812                 arg = fieldsize;
 813                 while (arg--)
 814                     *t++ = ' ';
 815                 break;
 816             }
 817             gotsome = TRUE;
 818             value = SvNV(sv);
 819             /* overflow evidence */
 820             if (num_overflow(value, fieldsize, arg)) {
 821                 arg = fieldsize;
 822                 while (arg--)
 823                     *t++ = '#';
 824                 break;
 825             }
 826             /* Formats aren't yet marked for locales, so assume "yes". */
 827             {
 828                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 829                 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
 830                 RESTORE_NUMERIC_STANDARD();
 831             }
 832             t += fieldsize;
 833             break;
 834
 835         case FF_NEWLINE:
 836             f++;
 837             while (t-- > linemark && *t == ' ') ;
 838             t++;
 839             *t++ = '\n';
 840             break;
 841
 842         case FF_BLANK:
 843             arg = *fpc++;
 844             if (gotsome) {
 845                 if (arg) {              /* repeat until fields exhausted? */
 846                     *t = '\0';
 847                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 848                     lines += FmLINES(PL_formtarget);
 849                     if (lines == 200) {
 850                         arg = t - linemark;
 851                         if (strnEQ(linemark, linemark - arg, arg))
 852                             DIE(aTHX_ "Runaway format");
 853                     }
 854                     if (targ_is_utf8)
 855                         SvUTF8_on(PL_formtarget);
 856                     FmLINES(PL_formtarget) = lines;
 857                     SP = ORIGMARK;
 858                     RETURNOP(cLISTOP->op_first);
 859                 }
 860             }
 861             else {
 862                 t = linemark;
 863                 lines--;
 864             }
 865             break;
 866
 867         case FF_MORE:
 868             {
 869                 const char *s = chophere;
 870                 const char *send = item + len;
 871                 if (chopspace) {
 872                     while (*s && isSPACE(*s) && s < send)
 873                         s++;
 874                 }
 875                 if (s < send) {
 876                     char *s1;
 877                     arg = fieldsize - itemsize;
 878                     if (arg) {
 879                         fieldsize -= arg;
 880                         while (arg-- > 0)
 881                             *t++ = ' ';
 882                     }
 883                     s1 = t - 3;
 884                     if (strnEQ(s1,"   ",3)) {
 885                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 886                             s1--;
 887                     }
 888                     *s1++ = '.';
 889                     *s1++ = '.';
 890                     *s1++ = '.';
 891                 }
 892                 break;
 893             }
 894         case FF_END:
 895             *t = '\0';
 896             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 897             if (targ_is_utf8)
 898                 SvUTF8_on(PL_formtarget);
 899             FmLINES(PL_formtarget) += lines;
 900             SP = ORIGMARK;
 901             RETPUSHYES;
 902         }
 903     }
 904 }
 905
 906 PP(pp_grepstart)
 907 {
 908     dVAR; dSP;
 909     SV *src;
 910
 911     if (PL_stack_base + *PL_markstack_ptr == SP) {
 912         (void)POPMARK;
 913         if (GIMME_V == G_SCALAR)
 914             XPUSHs(sv_2mortal(newSViv(0)));
 915         RETURNOP(PL_op->op_next->op_next);
 916     }
 917     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 918     pp_pushmark();                              /* push dst */
 919     pp_pushmark();                              /* push src */
 920     ENTER;                                      /* enter outer scope */
 921
 922     SAVETMPS;
 923     if (PL_op->op_private & OPpGREP_LEX)
 924         SAVESPTR(PAD_SVl(PL_op->op_targ));
 925     else
 926         SAVE_DEFSV;
 927     ENTER;                                      /* enter inner scope */
 928     SAVEVPTR(PL_curpm);
 929
 930     src = PL_stack_base[*PL_markstack_ptr];
 931     SvTEMP_off(src);
 932     if (PL_op->op_private & OPpGREP_LEX)
 933         PAD_SVl(PL_op->op_targ) = src;
 934     else
 935         DEFSV = src;
 936
 937     PUTBACK;
 938     if (PL_op->op_type == OP_MAPSTART)
 939         pp_pushmark();                  /* push top */
 940     return ((LOGOP*)PL_op->op_next)->op_other;
 941 }
 942
 943 PP(pp_mapstart)
 944 {
 945     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 946 }
 947
 948 PP(pp_mapwhile)
 949 {
 950     dVAR; dSP;
 951     const I32 gimme = GIMME_V;
 952     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 953     I32 count;
 954     I32 shift;
 955     SV** src;
 956     SV** dst;
 957
 958     /* first, move source pointer to the next item in the source list */
 959     ++PL_markstack_ptr[-1];
 960
 961     /* if there are new items, push them into the destination list */
 962     if (items && gimme != G_VOID) {
 963         /* might need to make room back there first */
 964         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 965             /* XXX this implementation is very pessimal because the stack
 966              * is repeatedly extended for every set of items.  Is possible
 967              * to do this without any stack extension or copying at all
 968              * by maintaining a separate list over which the map iterates
 969              * (like foreach does). --gsar */
 970
 971             /* everything in the stack after the destination list moves
 972              * towards the end the stack by the amount of room needed */
 973             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 974
 975             /* items to shift up (accounting for the moved source pointer) */
 976             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 977
 978             /* This optimization is by Ben Tilly and it does
 979              * things differently from what Sarathy (gsar)
 980              * is describing.  The downside of this optimization is
 981              * that leaves "holes" (uninitialized and hopefully unused areas)
 982              * to the Perl stack, but on the other hand this
 983              * shouldn't be a problem.  If Sarathy's idea gets
 984              * implemented, this optimization should become
 985              * irrelevant.  --jhi */
 986             if (shift < count)
 987                 shift = count; /* Avoid shifting too often --Ben Tilly */
 988
 989             EXTEND(SP,shift);
 990             src = SP;
 991             dst = (SP += shift);
 992             PL_markstack_ptr[-1] += shift;
 993             *PL_markstack_ptr += shift;
 994             while (count--)
 995                 *dst-- = *src--;
 996         }
 997         /* copy the new items down to the destination list */
 998         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
 999         if (gimme == G_ARRAY) {
1000             while (items-- > 0)
1001                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1002         }
1003         else {
1004             /* scalar context: we don't care about which values map returns
1005              * (we use undef here). And so we certainly don't want to do mortal
1006              * copies of meaningless values. */
1007             while (items-- > 0) {
1008                 (void)POPs;
1009                 *dst-- = &PL_sv_undef;
1010             }
1011         }
1012     }
1013     LEAVE;                                      /* exit inner scope */
1014
1015     /* All done yet? */
1016     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1017
1018         (void)POPMARK;                          /* pop top */
1019         LEAVE;                                  /* exit outer scope */
1020         (void)POPMARK;                          /* pop src */
1021         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1022         (void)POPMARK;                          /* pop dst */
1023         SP = PL_stack_base + POPMARK;           /* pop original mark */
1024         if (gimme == G_SCALAR) {
1025             if (PL_op->op_private & OPpGREP_LEX) {
1026                 SV* sv = sv_newmortal();
1027                 sv_setiv(sv, items);
1028                 PUSHs(sv);
1029             }
1030             else {
1031                 dTARGET;
1032                 XPUSHi(items);
1033             }
1034         }
1035         else if (gimme == G_ARRAY)
1036             SP += items;
1037         RETURN;
1038     }
1039     else {
1040         SV *src;
1041
1042         ENTER;                                  /* enter inner scope */
1043         SAVEVPTR(PL_curpm);
1044
1045         /* set $_ to the new source item */
1046         src = PL_stack_base[PL_markstack_ptr[-1]];
1047         SvTEMP_off(src);
1048         if (PL_op->op_private & OPpGREP_LEX)
1049             PAD_SVl(PL_op->op_targ) = src;
1050         else
1051             DEFSV = src;
1052
1053         RETURNOP(cLOGOP->op_other);
1054     }
1055 }
1056
1057 /* Range stuff. */
1058
1059 PP(pp_range)
1060 {
1061     if (GIMME == G_ARRAY)
1062         return NORMAL;
1063     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1064         return cLOGOP->op_other;
1065     else
1066         return NORMAL;
1067 }
1068
1069 PP(pp_flip)
1070 {
1071     dSP;
1072
1073     if (GIMME == G_ARRAY) {
1074         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1075     }
1076     else {
1077         dTOPss;
1078         SV *targ = PAD_SV(PL_op->op_targ);
1079         int flip = 0;
1080
1081         if (PL_op->op_private & OPpFLIP_LINENUM) {
1082             if (GvIO(PL_last_in_gv)) {
1083                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1084             }
1085             else {
1086                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1087                 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1088             }
1089         } else {
1090             flip = SvTRUE(sv);
1091         }
1092         if (flip) {
1093             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1094             if (PL_op->op_flags & OPf_SPECIAL) {
1095                 sv_setiv(targ, 1);
1096                 SETs(targ);
1097                 RETURN;
1098             }
1099             else {
1100                 sv_setiv(targ, 0);
1101                 SP--;
1102                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1103             }
1104         }
1105         sv_setpvn(TARG, "", 0);
1106         SETs(targ);
1107         RETURN;
1108     }
1109 }
1110
1111 /* This code tries to decide if "$left .. $right" should use the
1112    magical string increment, or if the range is numeric (we make
1113    an exception for .."0" [#18165]). AMS 20021031. */
1114
1115 #define RANGE_IS_NUMERIC(left,right) ( \
1116         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1117         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1118         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1119           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1120          && (!SvOK(right) || looks_like_number(right))))
1121
1122 PP(pp_flop)
1123 {
1124     dSP;
1125
1126     if (GIMME == G_ARRAY) {
1127         dPOPPOPssrl;
1128
1129         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* const av = GvAV(PL_defgv);
2347                 items = AvFILLp(av) + 1;
2348                 EXTEND(SP, items+1); /* @_ could have been extended. */
2349                 Copy(AvARRAY(av), SP + 1, items, SV*);
2350             }
2351             mark = SP;
2352             SP += items;
2353             if (CxTYPE(cx) == CXt_SUB &&
2354                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2355                 SvREFCNT_dec(cx->blk_sub.cv);
2356             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2357             LEAVE_SCOPE(oldsave);
2358
2359             /* Now do some callish stuff. */
2360             SAVETMPS;
2361             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2362             if (CvXSUB(cv)) {
2363                 OP* retop = cx->blk_sub.retop;
2364                 if (reified) {
2365                     I32 index;
2366                     for (index=0; index<items; index++)
2367                         sv_2mortal(SP[-index]);
2368                 }
2369 #ifdef PERL_XSUB_OLDSTYLE
2370                 if (CvOLDSTYLE(cv)) {
2371                     I32 (*fp3)(int,int,int);
2372                     while (SP > mark) {
2373                         SP[1] = SP[0];
2374                         SP--;
2375                     }
2376                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2377                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2378                                    mark - PL_stack_base + 1,
2379                                    items);
2380                     SP = PL_stack_base + items;
2381                 }
2382                 else
2383 #endif /* PERL_XSUB_OLDSTYLE */
2384                 {
2385                     SV **newsp;
2386                     I32 gimme;
2387
2388                     /* XS subs don't have a CxSUB, so pop it */
2389                     POPBLOCK(cx, PL_curpm);
2390                     /* Push a mark for the start of arglist */
2391                     PUSHMARK(mark);
2392                     PUTBACK;
2393                     (void)(*CvXSUB(cv))(aTHX_ cv);
2394                     /* Put these at the bottom since the vars are set but not used */
2395                     PERL_UNUSED_VAR(newsp);
2396                     PERL_UNUSED_VAR(gimme);
2397                 }
2398                 LEAVE;
2399                 return retop;
2400             }
2401             else {
2402                 AV* padlist = CvPADLIST(cv);
2403                 if (CxTYPE(cx) == CXt_EVAL) {
2404                     PL_in_eval = cx->blk_eval.old_in_eval;
2405                     PL_eval_root = cx->blk_eval.old_eval_root;
2406                     cx->cx_type = CXt_SUB;
2407                     cx->blk_sub.hasargs = 0;
2408                 }
2409                 cx->blk_sub.cv = cv;
2410                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2411
2412                 CvDEPTH(cv)++;
2413                 if (CvDEPTH(cv) < 2)
2414                     (void)SvREFCNT_inc(cv);
2415                 else {
2416                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2417                         sub_crush_depth(cv);
2418                     pad_push(padlist, CvDEPTH(cv));
2419                 }
2420                 SAVECOMPPAD();
2421                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2422                 if (cx->blk_sub.hasargs)
2423                 {
2424                     AV* av = (AV*)PAD_SVl(0);
2425                     SV** ary;
2426
2427                     cx->blk_sub.savearray = GvAV(PL_defgv);
2428                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2429                     CX_CURPAD_SAVE(cx->blk_sub);
2430                     cx->blk_sub.argarray = av;
2431
2432                     if (items >= AvMAX(av) + 1) {
2433                         ary = AvALLOC(av);
2434                         if (AvARRAY(av) != ary) {
2435                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2436                             SvPV_set(av, (char*)ary);
2437                         }
2438                         if (items >= AvMAX(av) + 1) {
2439                             AvMAX(av) = items - 1;
2440                             Renew(ary,items+1,SV*);
2441                             AvALLOC(av) = ary;
2442                             SvPV_set(av, (char*)ary);
2443                         }
2444                     }
2445                     ++mark;
2446                     Copy(mark,AvARRAY(av),items,SV*);
2447                     AvFILLp(av) = items - 1;
2448                     assert(!AvREAL(av));
2449                     if (reified) {
2450                         /* transfer 'ownership' of refcnts to new @_ */
2451                         AvREAL_on(av);
2452                         AvREIFY_off(av);
2453                     }
2454                     while (items--) {
2455                         if (*mark)
2456                             SvTEMP_off(*mark);
2457                         mark++;
2458                     }
2459                 }
2460                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2461                     /*
2462                      * We do not care about using sv to call CV;
2463                      * it's for informational purposes only.
2464                      */
2465                     SV * const sv = GvSV(PL_DBsub);
2466                     CV *gotocv;
2467
2468                     save_item(sv);
2469                     if (PERLDB_SUB_NN) {
2470                         const int type = SvTYPE(sv);
2471                         if (type < SVt_PVIV && type != SVt_IV)
2472                             sv_upgrade(sv, SVt_PVIV);
2473                         (void)SvIOK_on(sv);
2474                         SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2475                     } else {
2476                         gv_efullname3(sv, CvGV(cv), Nullch);
2477                     }
2478                     if (  PERLDB_GOTO
2479                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2480                         PUSHMARK( PL_stack_sp );
2481                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2482                         PL_stack_sp--;
2483                     }
2484                 }
2485                 RETURNOP(CvSTART(cv));
2486             }
2487         }
2488         else {
2489             label = SvPV_nolen_const(sv);
2490             if (!(do_dump || *label))
2491                 DIE(aTHX_ must_have_label);
2492         }
2493     }
2494     else if (PL_op->op_flags & OPf_SPECIAL) {
2495         if (! do_dump)
2496             DIE(aTHX_ must_have_label);
2497     }
2498     else
2499         label = cPVOP->op_pv;
2500
2501     if (label && *label) {
2502         OP *gotoprobe = 0;
2503         bool leaving_eval = FALSE;
2504         bool in_block = FALSE;
2505         PERL_CONTEXT *last_eval_cx = 0;
2506
2507         /* find label */
2508
2509         PL_lastgotoprobe = 0;
2510         *enterops = 0;
2511         for (ix = cxstack_ix; ix >= 0; ix--) {
2512             cx = &cxstack[ix];
2513             switch (CxTYPE(cx)) {
2514             case CXt_EVAL:
2515                 leaving_eval = TRUE;
2516                 if (!CxTRYBLOCK(cx)) {
2517                     gotoprobe = (last_eval_cx ?
2518                                 last_eval_cx->blk_eval.old_eval_root :
2519                                 PL_eval_root);
2520                     last_eval_cx = cx;
2521                     break;
2522                 }
2523                 /* else fall through */
2524             case CXt_LOOP:
2525                 gotoprobe = cx->blk_oldcop->op_sibling;
2526                 break;
2527             case CXt_SUBST:
2528                 continue;
2529             case CXt_BLOCK:
2530                 if (ix) {
2531                     gotoprobe = cx->blk_oldcop->op_sibling;
2532                     in_block = TRUE;
2533                 } else
2534                     gotoprobe = PL_main_root;
2535                 break;
2536             case CXt_SUB:
2537                 if (CvDEPTH(cx->blk_sub.cv)) {
2538                     gotoprobe = CvROOT(cx->blk_sub.cv);
2539                     break;
2540                 }
2541                 /* FALL THROUGH */
2542             case CXt_FORMAT:
2543             case CXt_NULL:
2544                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2545             default:
2546                 if (ix)
2547                     DIE(aTHX_ "panic: goto");
2548                 gotoprobe = PL_main_root;
2549                 break;
2550             }
2551             if (gotoprobe) {
2552                 retop = dofindlabel(gotoprobe, label,
2553                                     enterops, enterops + GOTO_DEPTH);
2554                 if (retop)
2555                     break;
2556             }
2557             PL_lastgotoprobe = gotoprobe;
2558         }
2559         if (!retop)
2560             DIE(aTHX_ "Can't find label %s", label);
2561
2562         /* if we're leaving an eval, check before we pop any frames
2563            that we're not going to punt, otherwise the error
2564            won't be caught */
2565
2566         if (leaving_eval && *enterops && enterops[1]) {
2567             I32 i;
2568             for (i = 1; enterops[i]; i++)
2569                 if (enterops[i]->op_type == OP_ENTERITER)
2570                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2571         }
2572
2573         /* pop unwanted frames */
2574
2575         if (ix < cxstack_ix) {
2576             I32 oldsave;
2577
2578             if (ix < 0)
2579                 ix = 0;
2580             dounwind(ix);
2581             TOPBLOCK(cx);
2582             oldsave = PL_scopestack[PL_scopestack_ix];
2583             LEAVE_SCOPE(oldsave);
2584         }
2585
2586         /* push wanted frames */
2587
2588         if (*enterops && enterops[1]) {
2589             OP *oldop = PL_op;
2590             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2591             for (; enterops[ix]; ix++) {
2592                 PL_op = enterops[ix];
2593                 /* Eventually we may want to stack the needed arguments
2594                  * for each op.  For now, we punt on the hard ones. */
2595                 if (PL_op->op_type == OP_ENTERITER)
2596                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2597                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2598             }
2599             PL_op = oldop;
2600         }
2601     }
2602
2603     if (do_dump) {
2604 #ifdef VMS
2605         if (!retop) retop = PL_main_start;
2606 #endif
2607         PL_restartop = retop;
2608         PL_do_undump = TRUE;
2609
2610         my_unexec();
2611
2612         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2613         PL_do_undump = FALSE;
2614     }
2615
2616     RETURNOP(retop);
2617 }
2618
2619 PP(pp_exit)
2620 {
2621     dSP;
2622     I32 anum;
2623
2624     if (MAXARG < 1)
2625         anum = 0;
2626     else {
2627         anum = SvIVx(POPs);
2628 #ifdef VMS
2629         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2630             anum = 0;
2631         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2632 #endif
2633     }
2634     PL_exit_flags |= PERL_EXIT_EXPECTED;
2635     my_exit(anum);
2636     PUSHs(&PL_sv_undef);
2637     RETURN;
2638 }
2639
2640 #ifdef NOTYET
2641 PP(pp_nswitch)
2642 {
2643     dSP;
2644     const NV value = SvNVx(GvSV(cCOP->cop_gv));
2645     register I32 match = I_32(value);
2646
2647     if (value < 0.0) {
2648         if (((NV)match) > value)
2649             --match;            /* was fractional--truncate other way */
2650     }
2651     match -= cCOP->uop.scop.scop_offset;
2652     if (match < 0)
2653         match = 0;
2654     else if (match > cCOP->uop.scop.scop_max)
2655         match = cCOP->uop.scop.scop_max;
2656     PL_op = cCOP->uop.scop.scop_next[match];
2657     RETURNOP(PL_op);
2658 }
2659
2660 PP(pp_cswitch)
2661 {
2662     dSP;
2663     register I32 match;
2664
2665     if (PL_multiline)
2666         PL_op = PL_op->op_next;                 /* can't assume anything */
2667     else {
2668         match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2669         match -= cCOP->uop.scop.scop_offset;
2670         if (match < 0)
2671             match = 0;
2672         else if (match > cCOP->uop.scop.scop_max)
2673             match = cCOP->uop.scop.scop_max;
2674         PL_op = cCOP->uop.scop.scop_next[match];
2675     }
2676     RETURNOP(PL_op);
2677 }
2678 #endif
2679
2680 /* Eval. */
2681
2682 STATIC void
2683 S_save_lines(pTHX_ AV *array, SV *sv)
2684 {
2685     const char *s = SvPVX_const(sv);
2686     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2687     I32 line = 1;
2688
2689     while (s && s < send) {
2690         const char *t;
2691         SV * const tmpstr = NEWSV(85,0);
2692
2693         sv_upgrade(tmpstr, SVt_PVMG);
2694         t = strchr(s, '\n');
2695         if (t)
2696             t++;
2697         else
2698             t = send;
2699
2700         sv_setpvn(tmpstr, s, t - s);
2701         av_store(array, line++, tmpstr);
2702         s = t;
2703     }
2704 }
2705
2706 STATIC void
2707 S_docatch_body(pTHX)
2708 {
2709     CALLRUNOPS(aTHX);
2710     return;
2711 }
2712
2713 STATIC OP *
2714 S_docatch(pTHX_ OP *o)
2715 {
2716     int ret;
2717     OP * const oldop = PL_op;
2718     dJMPENV;
2719
2720 #ifdef DEBUGGING
2721     assert(CATCH_GET == TRUE);
2722 #endif
2723     PL_op = o;
2724
2725     JMPENV_PUSH(ret);
2726     switch (ret) {
2727     case 0:
2728         assert(cxstack_ix >= 0);
2729         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2730         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2731  redo_body:
2732         docatch_body();
2733         break;
2734     case 3:
2735         /* die caught by an inner eval - continue inner loop */
2736
2737         /* NB XXX we rely on the old popped CxEVAL still being at the top
2738          * of the stack; the way die_where() currently works, this
2739          * assumption is valid. In theory The cur_top_env value should be
2740          * returned in another global, the way retop (aka PL_restartop)
2741          * is. */
2742         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2743
2744         if (PL_restartop
2745             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2746         {
2747             PL_op = PL_restartop;
2748             PL_restartop = 0;
2749             goto redo_body;
2750         }
2751         /* FALL THROUGH */
2752     default:
2753         JMPENV_POP;
2754         PL_op = oldop;
2755         JMPENV_JUMP(ret);
2756         /* NOTREACHED */
2757     }
2758     JMPENV_POP;
2759     PL_op = oldop;
2760     return Nullop;
2761 }
2762
2763 OP *
2764 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2765 /* sv Text to convert to OP tree. */
2766 /* startop op_free() this to undo. */
2767 /* code Short string id of the caller. */
2768 {
2769     dVAR; dSP;                          /* Make POPBLOCK work. */
2770     PERL_CONTEXT *cx;
2771     SV **newsp;
2772     I32 gimme = G_VOID;
2773     I32 optype;
2774     OP dummy;
2775     OP *rop;
2776     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2777     char *tmpbuf = tbuf;
2778     char *safestr;
2779     int runtime;
2780     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2781
2782     ENTER;
2783     lex_start(sv);
2784     SAVETMPS;
2785     /* switch to eval mode */
2786
2787     if (IN_PERL_COMPILETIME) {
2788         SAVECOPSTASH_FREE(&PL_compiling);
2789         CopSTASH_set(&PL_compiling, PL_curstash);
2790     }
2791     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2792         SV * const sv = sv_newmortal();
2793         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2794                        code, (unsigned long)++PL_evalseq,
2795                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2796         tmpbuf = SvPVX(sv);
2797     }
2798     else
2799         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2800     SAVECOPFILE_FREE(&PL_compiling);
2801     CopFILE_set(&PL_compiling, tmpbuf+2);
2802     SAVECOPLINE(&PL_compiling);
2803     CopLINE_set(&PL_compiling, 1);
2804     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2805        deleting the eval's FILEGV from the stash before gv_check() runs
2806        (i.e. before run-time proper). To work around the coredump that
2807        ensues, we always turn GvMULTI_on for any globals that were
2808        introduced within evals. See force_ident(). GSAR 96-10-12 */
2809     safestr = savepv(tmpbuf);
2810     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2811     SAVEHINTS();
2812 #ifdef OP_IN_REGISTER
2813     PL_opsave = op;
2814 #else
2815     SAVEVPTR(PL_op);
2816 #endif
2817
2818     /* we get here either during compilation, or via pp_regcomp at runtime */
2819     runtime = IN_PERL_RUNTIME;
2820     if (runtime)
2821         runcv = find_runcv(NULL);
2822
2823     PL_op = &dummy;
2824     PL_op->op_type = OP_ENTEREVAL;
2825     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2826     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2827     PUSHEVAL(cx, 0, Nullgv);
2828
2829     if (runtime)
2830         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2831     else
2832         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2833     POPBLOCK(cx,PL_curpm);
2834     POPEVAL(cx);
2835
2836     (*startop)->op_type = OP_NULL;
2837     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2838     lex_end();
2839     /* XXX DAPM do this properly one year */
2840     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2841     LEAVE;
2842     if (IN_PERL_COMPILETIME)
2843         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2844 #ifdef OP_IN_REGISTER
2845     op = PL_opsave;
2846 #endif
2847     PERL_UNUSED_VAR(newsp);
2848     PERL_UNUSED_VAR(optype);
2849
2850     return rop;
2851 }
2852
2853
2854 /*
2855 =for apidoc find_runcv
2856
2857 Locate the CV corresponding to the currently executing sub or eval.
2858 If db_seqp is non_null, skip CVs that are in the DB package and populate
2859 *db_seqp with the cop sequence number at the point that the DB:: code was
2860 entered. (allows debuggers to eval in the scope of the breakpoint rather
2861 than in in the scope of the debugger itself).
2862
2863 =cut
2864 */
2865
2866 CV*
2867 Perl_find_runcv(pTHX_ U32 *db_seqp)
2868 {
2869     PERL_SI      *si;
2870
2871     if (db_seqp)
2872         *db_seqp = PL_curcop->cop_seq;
2873     for (si = PL_curstackinfo; si; si = si->si_prev) {
2874         I32 ix;
2875         for (ix = si->si_cxix; ix >= 0; ix--) {
2876             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2877             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2878                 CV * const cv = cx->blk_sub.cv;
2879                 /* skip DB:: code */
2880                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2881                     *db_seqp = cx->blk_oldcop->cop_seq;
2882                     continue;
2883                 }
2884                 return cv;
2885             }
2886             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2887                 return PL_compcv;
2888         }
2889     }
2890     return PL_main_cv;
2891 }
2892
2893
2894 /* Compile a require/do, an eval '', or a /(?{...})/.
2895  * In the last case, startop is non-null, and contains the address of
2896  * a pointer that should be set to the just-compiled code.
2897  * outside is the lexically enclosing CV (if any) that invoked us.
2898  */
2899
2900 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2901 STATIC OP *
2902 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2903 {
2904     dVAR; dSP;
2905     OP *saveop = PL_op;
2906
2907     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2908                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2909                   : EVAL_INEVAL);
2910
2911     PUSHMARK(SP);
2912
2913     SAVESPTR(PL_compcv);
2914     PL_compcv = (CV*)NEWSV(1104,0);
2915     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2916     CvEVAL_on(PL_compcv);
2917     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2918     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2919
2920     CvOUTSIDE_SEQ(PL_compcv) = seq;
2921     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2922
2923     /* set up a scratch pad */
2924
2925     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2926
2927
2928     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2929
2930     /* make sure we compile in the right package */
2931
2932     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2933         SAVESPTR(PL_curstash);
2934         PL_curstash = CopSTASH(PL_curcop);
2935     }
2936     SAVESPTR(PL_beginav);
2937     PL_beginav = newAV();
2938     SAVEFREESV(PL_beginav);
2939     SAVEI32(PL_error_count);
2940
2941     /* try to compile it */
2942
2943     PL_eval_root = Nullop;
2944     PL_error_count = 0;
2945     PL_curcop = &PL_compiling;
2946     PL_curcop->cop_arybase = 0;
2947     if (saveop && saveop->op_flags & OPf_SPECIAL)
2948         PL_in_eval |= EVAL_KEEPERR;
2949     else
2950         sv_setpvn(ERRSV,"",0);
2951     if (yyparse() || PL_error_count || !PL_eval_root) {
2952         SV **newsp;                     /* Used by POPBLOCK. */
2953         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2954         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2955         const char *msg;
2956
2957         PL_op = saveop;
2958         if (PL_eval_root) {
2959             op_free(PL_eval_root);
2960             PL_eval_root = Nullop;
2961         }
2962         SP = PL_stack_base + POPMARK;           /* pop original mark */
2963         if (!startop) {
2964             POPBLOCK(cx,PL_curpm);
2965             POPEVAL(cx);
2966         }
2967         lex_end();
2968         LEAVE;
2969
2970         msg = SvPVx_nolen_const(ERRSV);
2971         if (optype == OP_REQUIRE) {
2972             const SV * const nsv = cx->blk_eval.old_namesv;
2973             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2974                           &PL_sv_undef, 0);
2975             DIE(aTHX_ "%sCompilation failed in require",
2976                 *msg ? msg : "Unknown error\n");
2977         }
2978         else if (startop) {
2979             POPBLOCK(cx,PL_curpm);
2980             POPEVAL(cx);
2981             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2982                        (*msg ? msg : "Unknown error\n"));
2983         }
2984         else {
2985             if (!*msg) {
2986                 sv_setpv(ERRSV, "Compilation error");
2987             }
2988         }
2989         PERL_UNUSED_VAR(newsp);
2990         RETPUSHUNDEF;
2991     }
2992     CopLINE_set(&PL_compiling, 0);
2993     if (startop) {
2994         *startop = PL_eval_root;
2995     } else
2996         SAVEFREEOP(PL_eval_root);
2997
2998     /* Set the context for this new optree.
2999      * If the last op is an OP_REQUIRE, force scalar context.
3000      * Otherwise, propagate the context from the eval(). */
3001     if (PL_eval_root->op_type == OP_LEAVEEVAL
3002             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3003             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3004             == OP_REQUIRE)
3005         scalar(PL_eval_root);
3006     else if (gimme & G_VOID)
3007         scalarvoid(PL_eval_root);
3008     else if (gimme & G_ARRAY)
3009         list(PL_eval_root);
3010     else
3011         scalar(PL_eval_root);
3012
3013     DEBUG_x(dump_eval());
3014
3015     /* Register with debugger: */
3016     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3017         CV * const cv = get_cv("DB::postponed", FALSE);
3018         if (cv) {
3019             dSP;
3020             PUSHMARK(SP);
3021             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3022             PUTBACK;
3023             call_sv((SV*)cv, G_DISCARD);
3024         }
3025     }
3026
3027     /* compiled okay, so do it */
3028
3029     CvDEPTH(PL_compcv) = 1;
3030     SP = PL_stack_base + POPMARK;               /* pop original mark */
3031     PL_op = saveop;                     /* The caller may need it. */
3032     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3033
3034     RETURNOP(PL_eval_start);
3035 }
3036
3037 STATIC PerlIO *
3038 S_doopen_pm(pTHX_ const char *name, const char *mode)
3039 {
3040 #ifndef PERL_DISABLE_PMC
3041     const STRLEN namelen = strlen(name);
3042     PerlIO *fp;
3043
3044     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3045         SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3046         const char * const pmc = SvPV_nolen_const(pmcsv);
3047         Stat_t pmcstat;
3048         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3049             fp = PerlIO_open(name, mode);
3050         }
3051         else {
3052             Stat_t pmstat;
3053             if (PerlLIO_stat(name, &pmstat) < 0 ||
3054                 pmstat.st_mtime < pmcstat.st_mtime)
3055             {
3056                 fp = PerlIO_open(pmc, mode);
3057             }
3058             else {
3059                 fp = PerlIO_open(name, mode);
3060             }
3061         }
3062         SvREFCNT_dec(pmcsv);
3063     }
3064     else {
3065         fp = PerlIO_open(name, mode);
3066     }
3067     return fp;
3068 #else
3069     return PerlIO_open(name, mode);
3070 #endif /* !PERL_DISABLE_PMC */
3071 }
3072
3073 PP(pp_require)
3074 {
3075     dVAR; dSP;
3076     register PERL_CONTEXT *cx;
3077     SV *sv;
3078     const char *name;
3079     STRLEN len;
3080     const char *tryname = Nullch;
3081     SV *namesv = Nullsv;
3082     SV** svp;
3083     const I32 gimme = GIMME_V;
3084     PerlIO *tryrsfp = 0;
3085     int filter_has_file = 0;
3086     GV *filter_child_proc = 0;
3087     SV *filter_state = 0;
3088     SV *filter_sub = 0;
3089     SV *hook_sv = 0;
3090     SV *encoding;
3091     OP *op;
3092
3093     sv = POPs;
3094     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3095         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3096                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3097                         "v-string in use/require non-portable");
3098
3099         sv = new_version(sv);
3100         if (!sv_derived_from(PL_patchlevel, "version"))
3101             (void *)upg_version(PL_patchlevel);
3102         if ( vcmp(sv,PL_patchlevel) > 0 )
3103             DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3104                 vnormal(sv), vnormal(PL_patchlevel));
3105
3106             RETPUSHYES;
3107     }
3108     name = SvPV_const(sv, len);
3109     if (!(name && len > 0 && *name))
3110         DIE(aTHX_ "Null filename used");
3111     TAINT_PROPER("require");
3112     if (PL_op->op_type == OP_REQUIRE &&
3113        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3114        if (*svp != &PL_sv_undef)
3115            RETPUSHYES;
3116        else
3117            DIE(aTHX_ "Compilation failed in require");
3118     }
3119
3120     /* prepare to compile file */
3121
3122     if (path_is_absolute(name)) {
3123         tryname = name;
3124         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3125     }
3126 #ifdef MACOS_TRADITIONAL
3127     if (!tryrsfp) {
3128         char newname[256];
3129
3130         MacPerl_CanonDir(name, newname, 1);
3131         if (path_is_absolute(newname)) {
3132             tryname = newname;
3133             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3134         }
3135     }
3136 #endif
3137     if (!tryrsfp) {
3138         AV *ar = GvAVn(PL_incgv);
3139         I32 i;
3140 #ifdef VMS
3141         char *unixname;
3142         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3143 #endif
3144         {
3145             namesv = NEWSV(806, 0);
3146             for (i = 0; i <= AvFILL(ar); i++) {
3147                 SV *dirsv = *av_fetch(ar, i, TRUE);
3148
3149                 if (SvROK(dirsv)) {
3150                     int count;
3151                     SV *loader = dirsv;
3152
3153                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3154                         && !sv_isobject(loader))
3155                     {
3156                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3157                     }
3158
3159                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3160                                    PTR2UV(SvRV(dirsv)), name);
3161                     tryname = SvPVX_const(namesv);
3162                     tryrsfp = 0;
3163
3164                     ENTER;
3165                     SAVETMPS;
3166                     EXTEND(SP, 2);
3167
3168                     PUSHMARK(SP);
3169                     PUSHs(dirsv);
3170                     PUSHs(sv);
3171                     PUTBACK;
3172                     if (sv_isobject(loader))
3173                         count = call_method("INC", G_ARRAY);
3174                     else
3175                         count = call_sv(loader, G_ARRAY);
3176                     SPAGAIN;
3177
3178                     if (count > 0) {
3179                         int i = 0;
3180                         SV *arg;
3181
3182                         SP -= count - 1;
3183                         arg = SP[i++];
3184
3185                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3186                             arg = SvRV(arg);
3187                         }
3188
3189                         if (SvTYPE(arg) == SVt_PVGV) {
3190                             IO *io = GvIO((GV *)arg);
3191
3192                             ++filter_has_file;
3193
3194                             if (io) {
3195                                 tryrsfp = IoIFP(io);
3196                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3197                                     /* reading from a child process doesn't
3198                                        nest -- when returning from reading
3199                                        the inner module, the outer one is
3200                                        unreadable (closed?)  I've tried to
3201                                        save the gv to manage the lifespan of
3202                                        the pipe, but this didn't help. XXX */
3203                                     filter_child_proc = (GV *)arg;
3204                                     (void)SvREFCNT_inc(filter_child_proc);
3205                                 }
3206                                 else {
3207                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3208                                         PerlIO_close(IoOFP(io));
3209                                     }
3210                                     IoIFP(io) = Nullfp;
3211                                     IoOFP(io) = Nullfp;
3212                                 }
3213                             }
3214
3215                             if (i < count) {
3216                                 arg = SP[i++];
3217                             }
3218                         }
3219
3220                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3221                             filter_sub = arg;
3222                             (void)SvREFCNT_inc(filter_sub);
3223
3224                             if (i < count) {
3225                                 filter_state = SP[i];
3226                                 (void)SvREFCNT_inc(filter_state);
3227                             }
3228
3229                             if (tryrsfp == 0) {
3230                                 tryrsfp = PerlIO_open("/dev/null",
3231                                                       PERL_SCRIPT_MODE);
3232                             }
3233                         }
3234                         SP--;
3235                     }
3236
3237                     PUTBACK;
3238                     FREETMPS;
3239                     LEAVE;
3240
3241                     if (tryrsfp) {
3242                         hook_sv = dirsv;
3243                         break;
3244                     }
3245
3246                     filter_has_file = 0;
3247                     if (filter_child_proc) {
3248                         SvREFCNT_dec(filter_child_proc);
3249                         filter_child_proc = 0;
3250                     }
3251                     if (filter_state) {
3252                         SvREFCNT_dec(filter_state);
3253                         filter_state = 0;
3254                     }
3255                     if (filter_sub) {
3256                         SvREFCNT_dec(filter_sub);
3257                         filter_sub = 0;
3258                     }
3259                 }
3260                 else {
3261                   if (!path_is_absolute(name)
3262 #ifdef MACOS_TRADITIONAL
3263                         /* We consider paths of the form :a:b ambiguous and interpret them first
3264                            as global then as local
3265                         */
3266                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3267 #endif
3268                   ) {
3269                     const char *dir = SvPVx_nolen_const(dirsv);
3270 #ifdef MACOS_TRADITIONAL
3271                     char buf1[256];
3272                     char buf2[256];
3273
3274                     MacPerl_CanonDir(name, buf2, 1);
3275                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3276 #else
3277 #  ifdef VMS
3278                     char *unixdir;
3279                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3280                         continue;
3281                     sv_setpv(namesv, unixdir);
3282                     sv_catpv(namesv, unixname);
3283 #  else
3284 #    ifdef SYMBIAN
3285                     if (PL_origfilename[0] &&
3286                         PL_origfilename[1] == ':' &&
3287                         !(dir[0] && dir[1] == ':'))
3288                         Perl_sv_setpvf(aTHX_ namesv,
3289                                        "%c:%s\\%s",
3290                                        PL_origfilename[0],
3291                                        dir, name);
3292                     else
3293                         Perl_sv_setpvf(aTHX_ namesv,
3294                                        "%s\\%s",
3295                                        dir, name);
3296 #    else
3297                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3298 #    endif
3299 #  endif
3300 #endif
3301                     TAINT_PROPER("require");
3302                     tryname = SvPVX_const(namesv);
3303                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3304                     if (tryrsfp) {
3305                         if (tryname[0] == '.' && tryname[1] == '/')
3306                             tryname += 2;
3307                         break;
3308                     }
3309                   }
3310                 }
3311             }
3312         }
3313     }
3314     SAVECOPFILE_FREE(&PL_compiling);
3315     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3316     SvREFCNT_dec(namesv);
3317     if (!tryrsfp) {
3318         if (PL_op->op_type == OP_REQUIRE) {
3319             const char *msgstr = name;
3320             if (namesv) {                       /* did we lookup @INC? */
3321                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3322                 SV *dirmsgsv = NEWSV(0, 0);
3323                 AV *ar = GvAVn(PL_incgv);
3324                 I32 i;
3325                 sv_catpvn(msg, " in @INC", 8);
3326                 if (instr(SvPVX_const(msg), ".h "))
3327                     sv_catpv(msg, " (change .h to .ph maybe?)");
3328                 if (instr(SvPVX_const(msg), ".ph "))
3329                     sv_catpv(msg, " (did you run h2ph?)");
3330                 sv_catpv(msg, " (@INC contains:");
3331                 for (i = 0; i <= AvFILL(ar); i++) {
3332                     const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3333                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3334                     sv_catsv(msg, dirmsgsv);
3335                 }
3336                 sv_catpvn(msg, ")", 1);
3337                 SvREFCNT_dec(dirmsgsv);
3338                 msgstr = SvPV_nolen_const(msg);
3339             }
3340             DIE(aTHX_ "Can't locate %s", msgstr);
3341         }
3342
3343         RETPUSHUNDEF;
3344     }
3345     else
3346         SETERRNO(0, SS_NORMAL);
3347
3348     /* Assume success here to prevent recursive requirement. */
3349     len = strlen(name);
3350     /* Check whether a hook in @INC has already filled %INC */
3351     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3352         (void)hv_store(GvHVn(PL_incgv), name, len,
3353                        (hook_sv ? SvREFCNT_inc(hook_sv)
3354                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3355                        0 );
3356     }
3357
3358     ENTER;
3359     SAVETMPS;
3360     lex_start(sv_2mortal(newSVpvn("",0)));
3361     SAVEGENERICSV(PL_rsfp_filters);
3362     PL_rsfp_filters = Nullav;
3363
3364     PL_rsfp = tryrsfp;
3365     SAVEHINTS();
3366     PL_hints = 0;
3367     SAVESPTR(PL_compiling.cop_warnings);
3368     if (PL_dowarn & G_WARN_ALL_ON)
3369         PL_compiling.cop_warnings = pWARN_ALL ;
3370     else if (PL_dowarn & G_WARN_ALL_OFF)
3371         PL_compiling.cop_warnings = pWARN_NONE ;
3372     else if (PL_taint_warn)
3373         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3374     else
3375         PL_compiling.cop_warnings = pWARN_STD ;
3376     SAVESPTR(PL_compiling.cop_io);
3377     PL_compiling.cop_io = Nullsv;
3378
3379     if (filter_sub || filter_child_proc) {
3380         SV * const datasv = filter_add(run_user_filter, Nullsv);
3381         IoLINES(datasv) = filter_has_file;
3382         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3383         IoTOP_GV(datasv) = (GV *)filter_state;
3384         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3385     }
3386
3387     /* switch to eval mode */
3388     PUSHBLOCK(cx, CXt_EVAL, SP);
3389     PUSHEVAL(cx, name, Nullgv);
3390     cx->blk_eval.retop = PL_op->op_next;
3391
3392     SAVECOPLINE(&PL_compiling);
3393     CopLINE_set(&PL_compiling, 0);
3394
3395     PUTBACK;
3396
3397     /* Store and reset encoding. */
3398     encoding = PL_encoding;
3399     PL_encoding = Nullsv;
3400
3401     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3402
3403     /* Restore encoding. */
3404     PL_encoding = encoding;
3405
3406     return op;
3407 }
3408
3409 PP(pp_dofile)
3410 {
3411     return pp_require();
3412 }
3413
3414 PP(pp_entereval)
3415 {
3416     dVAR; dSP;
3417     register PERL_CONTEXT *cx;
3418     dPOPss;
3419     const I32 gimme = GIMME_V;
3420     const I32 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 * const 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     Newx(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  */