pp_ctl.c

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