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;
2059     OP *nextop;
2060     SV **newsp;
2061     PMOP *newpm;
2062     SV **mark;
2063     SV *sv = Nullsv;
2064
2065
2066     if (PL_op->op_flags & OPf_SPECIAL) {
2067         cxix = dopoptoloop(cxstack_ix);
2068         if (cxix < 0)
2069             DIE(aTHX_ "Can't \"last\" outside a loop block");
2070     }
2071     else {
2072         cxix = dopoptolabel(cPVOP->op_pv);
2073         if (cxix < 0)
2074             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2075     }
2076     if (cxix < cxstack_ix)
2077         dounwind(cxix);
2078
2079     POPBLOCK(cx,newpm);
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     PERL_UNUSED_VAR(optype);
2138     PERL_UNUSED_VAR(gimme);
2139     return nextop;
2140 }
2141
2142 PP(pp_next)
2143 {
2144     dVAR;
2145     I32 cxix;
2146     register PERL_CONTEXT *cx;
2147     I32 inner;
2148
2149     if (PL_op->op_flags & OPf_SPECIAL) {
2150         cxix = dopoptoloop(cxstack_ix);
2151         if (cxix < 0)
2152             DIE(aTHX_ "Can't \"next\" outside a loop block");
2153     }
2154     else {
2155         cxix = dopoptolabel(cPVOP->op_pv);
2156         if (cxix < 0)
2157             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2158     }
2159     if (cxix < cxstack_ix)
2160         dounwind(cxix);
2161
2162     /* clear off anything above the scope we're re-entering, but
2163      * save the rest until after a possible continue block */
2164     inner = PL_scopestack_ix;
2165     TOPBLOCK(cx);
2166     if (PL_scopestack_ix < inner)
2167         leave_scope(PL_scopestack[PL_scopestack_ix]);
2168     PL_curcop = cx->blk_oldcop;
2169     return cx->blk_loop.next_op;
2170 }
2171
2172 PP(pp_redo)
2173 {
2174     dVAR;
2175     I32 cxix;
2176     register PERL_CONTEXT *cx;
2177     I32 oldsave;
2178     OP* redo_op;
2179
2180     if (PL_op->op_flags & OPf_SPECIAL) {
2181         cxix = dopoptoloop(cxstack_ix);
2182         if (cxix < 0)
2183             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2184     }
2185     else {
2186         cxix = dopoptolabel(cPVOP->op_pv);
2187         if (cxix < 0)
2188             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2189     }
2190     if (cxix < cxstack_ix)
2191         dounwind(cxix);
2192
2193     redo_op = cxstack[cxix].blk_loop.redo_op;
2194     if (redo_op->op_type == OP_ENTER) {
2195         /* pop one less context to avoid $x being freed in while (my $x..) */
2196         cxstack_ix++;
2197         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2198         redo_op = redo_op->op_next;
2199     }
2200
2201     TOPBLOCK(cx);
2202     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2203     LEAVE_SCOPE(oldsave);
2204     FREETMPS;
2205     PL_curcop = cx->blk_oldcop;
2206     return redo_op;
2207 }
2208
2209 STATIC OP *
2210 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2211 {
2212     OP *kid = Nullop;
2213     OP **ops = opstack;
2214     static const char too_deep[] = "Target of goto is too deeply nested";
2215
2216     if (ops >= oplimit)
2217         Perl_croak(aTHX_ too_deep);
2218     if (o->op_type == OP_LEAVE ||
2219         o->op_type == OP_SCOPE ||
2220         o->op_type == OP_LEAVELOOP ||
2221         o->op_type == OP_LEAVESUB ||
2222         o->op_type == OP_LEAVETRY)
2223     {
2224         *ops++ = cUNOPo->op_first;
2225         if (ops >= oplimit)
2226             Perl_croak(aTHX_ too_deep);
2227     }
2228     *ops = 0;
2229     if (o->op_flags & OPf_KIDS) {
2230         /* First try all the kids at this level, since that's likeliest. */
2231         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2232             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2233                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2234                 return kid;
2235         }
2236         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2237             if (kid == PL_lastgotoprobe)
2238                 continue;
2239             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2240                 if (ops == opstack)
2241                     *ops++ = kid;
2242                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2243                          ops[-1]->op_type == OP_DBSTATE)
2244                     ops[-1] = kid;
2245                 else
2246                     *ops++ = kid;
2247             }
2248             if ((o = dofindlabel(kid, label, ops, oplimit)))
2249                 return o;
2250         }
2251     }
2252     *ops = 0;
2253     return 0;
2254 }
2255
2256 PP(pp_dump)
2257 {
2258     return pp_goto();
2259     /*NOTREACHED*/
2260 }
2261
2262 PP(pp_goto)
2263 {
2264     dVAR; dSP;
2265     OP *retop = 0;
2266     I32 ix;
2267     register PERL_CONTEXT *cx;
2268 #define GOTO_DEPTH 64
2269     OP *enterops[GOTO_DEPTH];
2270     const char *label = 0;
2271     const bool do_dump = (PL_op->op_type == OP_DUMP);
2272     static const char must_have_label[] = "goto must have label";
2273
2274     if (PL_op->op_flags & OPf_STACKED) {
2275         SV * const sv = POPs;
2276
2277         /* This egregious kludge implements goto &subroutine */
2278         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2279             I32 cxix;
2280             register PERL_CONTEXT *cx;
2281             CV* cv = (CV*)SvRV(sv);
2282             SV** mark;
2283             I32 items = 0;
2284             I32 oldsave;
2285             bool reified = 0;
2286
2287         retry:
2288             if (!CvROOT(cv) && !CvXSUB(cv)) {
2289                 const GV * const gv = CvGV(cv);
2290                 if (gv) {
2291                     GV *autogv;
2292                     SV *tmpstr;
2293                     /* autoloaded stub? */
2294                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2295                         goto retry;
2296                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2297                                           GvNAMELEN(gv), FALSE);
2298                     if (autogv && (cv = GvCV(autogv)))
2299                         goto retry;
2300                     tmpstr = sv_newmortal();
2301                     gv_efullname3(tmpstr, gv, Nullch);
2302                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2303                 }
2304                 DIE(aTHX_ "Goto undefined subroutine");
2305             }
2306
2307             /* First do some returnish stuff. */
2308             (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2309             FREETMPS;
2310             cxix = dopoptosub(cxstack_ix);
2311             if (cxix < 0)
2312                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2313             if (cxix < cxstack_ix)
2314                 dounwind(cxix);
2315             TOPBLOCK(cx);
2316             SPAGAIN;
2317             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2318             if (CxTYPE(cx) == CXt_EVAL) {
2319                 if (CxREALEVAL(cx))
2320                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2321                 else
2322                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2323             }
2324             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2325                 /* put @_ back onto stack */
2326                 AV* av = cx->blk_sub.argarray;
2327
2328                 items = AvFILLp(av) + 1;
2329                 EXTEND(SP, items+1); /* @_ could have been extended. */
2330                 Copy(AvARRAY(av), SP + 1, items, SV*);
2331                 SvREFCNT_dec(GvAV(PL_defgv));
2332                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2333                 CLEAR_ARGARRAY(av);
2334                 /* abandon @_ if it got reified */
2335                 if (AvREAL(av)) {
2336                     reified = 1;
2337                     SvREFCNT_dec(av);
2338                     av = newAV();
2339                     av_extend(av, items-1);
2340                     AvREIFY_only(av);
2341                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2342                 }
2343             }
2344             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2345                 AV* av;
2346                 av = GvAV(PL_defgv);
2347                 items = AvFILLp(av) + 1;
2348                 EXTEND(SP, items+1); /* @_ could have been extended. */
2349                 Copy(AvARRAY(av), SP + 1, items, SV*);
2350             }
2351             mark = SP;
2352             SP += items;
2353             if (CxTYPE(cx) == CXt_SUB &&
2354                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2355                 SvREFCNT_dec(cx->blk_sub.cv);
2356             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2357             LEAVE_SCOPE(oldsave);
2358
2359             /* Now do some callish stuff. */
2360             SAVETMPS;
2361             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2362             if (CvXSUB(cv)) {
2363                 OP* retop = cx->blk_sub.retop;
2364                 if (reified) {
2365                     I32 index;
2366                     for (index=0; index<items; index++)
2367                         sv_2mortal(SP[-index]);
2368                 }
2369 #ifdef PERL_XSUB_OLDSTYLE
2370                 if (CvOLDSTYLE(cv)) {
2371                     I32 (*fp3)(int,int,int);
2372                     while (SP > mark) {
2373                         SP[1] = SP[0];
2374                         SP--;
2375                     }
2376                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2377                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2378                                    mark - PL_stack_base + 1,
2379                                    items);
2380                     SP = PL_stack_base + items;
2381                 }
2382                 else
2383 #endif /* PERL_XSUB_OLDSTYLE */
2384                 {
2385                     SV **newsp;
2386                     I32 gimme;
2387
2388                     /* XS subs don't have a CxSUB, so pop it */
2389                     POPBLOCK(cx, PL_curpm);
2390                     /* Push a mark for the start of arglist */
2391                     PUSHMARK(mark);
2392                     PUTBACK;
2393                     (void)(*CvXSUB(cv))(aTHX_ cv);
2394                     /* Put these at the bottom since the vars are set but not used */
2395                     PERL_UNUSED_VAR(newsp);
2396                     PERL_UNUSED_VAR(gimme);
2397                 }
2398                 LEAVE;
2399                 return retop;
2400             }
2401             else {
2402                 AV* padlist = CvPADLIST(cv);
2403                 if (CxTYPE(cx) == CXt_EVAL) {
2404                     PL_in_eval = cx->blk_eval.old_in_eval;
2405                     PL_eval_root = cx->blk_eval.old_eval_root;
2406                     cx->cx_type = CXt_SUB;
2407                     cx->blk_sub.hasargs = 0;
2408                 }
2409                 cx->blk_sub.cv = cv;
2410                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2411
2412                 CvDEPTH(cv)++;
2413                 if (CvDEPTH(cv) < 2)
2414                     (void)SvREFCNT_inc(cv);
2415                 else {
2416                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2417                         sub_crush_depth(cv);
2418                     pad_push(padlist, CvDEPTH(cv));
2419                 }
2420                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2421                 if (cx->blk_sub.hasargs)
2422                 {
2423                     AV* av = (AV*)PAD_SVl(0);
2424                     SV** ary;
2425
2426                     cx->blk_sub.savearray = GvAV(PL_defgv);
2427                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2428                     CX_CURPAD_SAVE(cx->blk_sub);
2429                     cx->blk_sub.argarray = av;
2430
2431                     if (items >= AvMAX(av) + 1) {
2432                         ary = AvALLOC(av);
2433                         if (AvARRAY(av) != ary) {
2434                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2435                             SvPV_set(av, (char*)ary);
2436                         }
2437                         if (items >= AvMAX(av) + 1) {
2438                             AvMAX(av) = items - 1;
2439                             Renew(ary,items+1,SV*);
2440                             AvALLOC(av) = ary;
2441                             SvPV_set(av, (char*)ary);
2442                         }
2443                     }
2444                     ++mark;
2445                     Copy(mark,AvARRAY(av),items,SV*);
2446                     AvFILLp(av) = items - 1;
2447                     assert(!AvREAL(av));
2448                     if (reified) {
2449                         /* transfer 'ownership' of refcnts to new @_ */
2450                         AvREAL_on(av);
2451                         AvREIFY_off(av);
2452                     }
2453                     while (items--) {
2454                         if (*mark)
2455                             SvTEMP_off(*mark);
2456                         mark++;
2457                     }
2458                 }
2459                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2460                     /*
2461                      * We do not care about using sv to call CV;
2462                      * it's for informational purposes only.
2463                      */
2464                     SV *sv = GvSV(PL_DBsub);
2465                     CV *gotocv;
2466
2467                     save_item(sv);
2468                     if (PERLDB_SUB_NN) {
2469                         int type = SvTYPE(sv);
2470                         if (type < SVt_PVIV && type != SVt_IV)
2471                             sv_upgrade(sv, SVt_PVIV);
2472                         (void)SvIOK_on(sv);
2473                         SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2474                     } else {
2475                         gv_efullname3(sv, CvGV(cv), Nullch);
2476                     }
2477                     if (  PERLDB_GOTO
2478                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2479                         PUSHMARK( PL_stack_sp );
2480                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2481                         PL_stack_sp--;
2482                     }
2483                 }
2484                 RETURNOP(CvSTART(cv));
2485             }
2486         }
2487         else {
2488             label = SvPV_nolen_const(sv);
2489             if (!(do_dump || *label))
2490                 DIE(aTHX_ must_have_label);
2491         }
2492     }
2493     else if (PL_op->op_flags & OPf_SPECIAL) {
2494         if (! do_dump)
2495             DIE(aTHX_ must_have_label);
2496     }
2497     else
2498         label = cPVOP->op_pv;
2499
2500     if (label && *label) {
2501         OP *gotoprobe = 0;
2502         bool leaving_eval = FALSE;
2503         bool in_block = FALSE;
2504         PERL_CONTEXT *last_eval_cx = 0;
2505
2506         /* find label */
2507
2508         PL_lastgotoprobe = 0;
2509         *enterops = 0;
2510         for (ix = cxstack_ix; ix >= 0; ix--) {
2511             cx = &cxstack[ix];
2512             switch (CxTYPE(cx)) {
2513             case CXt_EVAL:
2514                 leaving_eval = TRUE;
2515                 if (!CxTRYBLOCK(cx)) {
2516                     gotoprobe = (last_eval_cx ?
2517                                 last_eval_cx->blk_eval.old_eval_root :
2518                                 PL_eval_root);
2519                     last_eval_cx = cx;
2520                     break;
2521                 }
2522                 /* else fall through */
2523             case CXt_LOOP:
2524                 gotoprobe = cx->blk_oldcop->op_sibling;
2525                 break;
2526             case CXt_SUBST:
2527                 continue;
2528             case CXt_BLOCK:
2529                 if (ix) {
2530                     gotoprobe = cx->blk_oldcop->op_sibling;
2531                     in_block = TRUE;
2532                 } else
2533                     gotoprobe = PL_main_root;
2534                 break;
2535             case CXt_SUB:
2536                 if (CvDEPTH(cx->blk_sub.cv)) {
2537                     gotoprobe = CvROOT(cx->blk_sub.cv);
2538                     break;
2539                 }
2540                 /* FALL THROUGH */
2541             case CXt_FORMAT:
2542             case CXt_NULL:
2543                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2544             default:
2545                 if (ix)
2546                     DIE(aTHX_ "panic: goto");
2547                 gotoprobe = PL_main_root;
2548                 break;
2549             }
2550             if (gotoprobe) {
2551                 retop = dofindlabel(gotoprobe, label,
2552                                     enterops, enterops + GOTO_DEPTH);
2553                 if (retop)
2554                     break;
2555             }
2556             PL_lastgotoprobe = gotoprobe;
2557         }
2558         if (!retop)
2559             DIE(aTHX_ "Can't find label %s", label);
2560
2561         /* if we're leaving an eval, check before we pop any frames
2562            that we're not going to punt, otherwise the error
2563            won't be caught */
2564
2565         if (leaving_eval && *enterops && enterops[1]) {
2566             I32 i;
2567             for (i = 1; enterops[i]; i++)
2568                 if (enterops[i]->op_type == OP_ENTERITER)
2569                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2570         }
2571
2572         /* pop unwanted frames */
2573
2574         if (ix < cxstack_ix) {
2575             I32 oldsave;
2576
2577             if (ix < 0)
2578                 ix = 0;
2579             dounwind(ix);
2580             TOPBLOCK(cx);
2581             oldsave = PL_scopestack[PL_scopestack_ix];
2582             LEAVE_SCOPE(oldsave);
2583         }
2584
2585         /* push wanted frames */
2586
2587         if (*enterops && enterops[1]) {
2588             OP *oldop = PL_op;
2589             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2590             for (; enterops[ix]; ix++) {
2591                 PL_op = enterops[ix];
2592                 /* Eventually we may want to stack the needed arguments
2593                  * for each op.  For now, we punt on the hard ones. */
2594                 if (PL_op->op_type == OP_ENTERITER)
2595                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2596                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2597             }
2598             PL_op = oldop;
2599         }
2600     }
2601
2602     if (do_dump) {
2603 #ifdef VMS
2604         if (!retop) retop = PL_main_start;
2605 #endif
2606         PL_restartop = retop;
2607         PL_do_undump = TRUE;
2608
2609         my_unexec();
2610
2611         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2612         PL_do_undump = FALSE;
2613     }
2614
2615     RETURNOP(retop);
2616 }
2617
2618 PP(pp_exit)
2619 {
2620     dSP;
2621     I32 anum;
2622
2623     if (MAXARG < 1)
2624         anum = 0;
2625     else {
2626         anum = SvIVx(POPs);
2627 #ifdef VMS
2628         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2629             anum = 0;
2630         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2631 #endif
2632     }
2633     PL_exit_flags |= PERL_EXIT_EXPECTED;
2634     my_exit(anum);
2635     PUSHs(&PL_sv_undef);
2636     RETURN;
2637 }
2638
2639 #ifdef NOTYET
2640 PP(pp_nswitch)
2641 {
2642     dSP;
2643     const NV value = SvNVx(GvSV(cCOP->cop_gv));
2644     register I32 match = I_32(value);
2645
2646     if (value < 0.0) {
2647         if (((NV)match) > value)
2648             --match;            /* was fractional--truncate other way */
2649     }
2650     match -= cCOP->uop.scop.scop_offset;
2651     if (match < 0)
2652         match = 0;
2653     else if (match > cCOP->uop.scop.scop_max)
2654         match = cCOP->uop.scop.scop_max;
2655     PL_op = cCOP->uop.scop.scop_next[match];
2656     RETURNOP(PL_op);
2657 }
2658
2659 PP(pp_cswitch)
2660 {
2661     dSP;
2662     register I32 match;
2663
2664     if (PL_multiline)
2665         PL_op = PL_op->op_next;                 /* can't assume anything */
2666     else {
2667         match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2668         match -= cCOP->uop.scop.scop_offset;
2669         if (match < 0)
2670             match = 0;
2671         else if (match > cCOP->uop.scop.scop_max)
2672             match = cCOP->uop.scop.scop_max;
2673         PL_op = cCOP->uop.scop.scop_next[match];
2674     }
2675     RETURNOP(PL_op);
2676 }
2677 #endif
2678
2679 /* Eval. */
2680
2681 STATIC void
2682 S_save_lines(pTHX_ AV *array, SV *sv)
2683 {
2684     const char *s = SvPVX_const(sv);
2685     const char *send = SvPVX_const(sv) + SvCUR(sv);
2686     I32 line = 1;
2687
2688     while (s && s < send) {
2689         const char *t;
2690         SV *tmpstr = NEWSV(85,0);
2691
2692         sv_upgrade(tmpstr, SVt_PVMG);
2693         t = strchr(s, '\n');
2694         if (t)
2695             t++;
2696         else
2697             t = send;
2698
2699         sv_setpvn(tmpstr, s, t - s);
2700         av_store(array, line++, tmpstr);
2701         s = t;
2702     }
2703 }
2704
2705 STATIC void
2706 S_docatch_body(pTHX)
2707 {
2708     CALLRUNOPS(aTHX);
2709     return;
2710 }
2711
2712 STATIC OP *
2713 S_docatch(pTHX_ OP *o)
2714 {
2715     int ret;
2716     OP * const oldop = PL_op;
2717     dJMPENV;
2718
2719 #ifdef DEBUGGING
2720     assert(CATCH_GET == TRUE);
2721 #endif
2722     PL_op = o;
2723
2724     JMPENV_PUSH(ret);
2725     switch (ret) {
2726     case 0:
2727         assert(cxstack_ix >= 0);
2728         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2729         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2730  redo_body:
2731         docatch_body();
2732         break;
2733     case 3:
2734         /* die caught by an inner eval - continue inner loop */
2735
2736         /* NB XXX we rely on the old popped CxEVAL still being at the top
2737          * of the stack; the way die_where() currently works, this
2738          * assumption is valid. In theory The cur_top_env value should be
2739          * returned in another global, the way retop (aka PL_restartop)
2740          * is. */
2741         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2742
2743         if (PL_restartop
2744             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2745         {
2746             PL_op = PL_restartop;
2747             PL_restartop = 0;
2748             goto redo_body;
2749         }
2750         /* FALL THROUGH */
2751     default:
2752         JMPENV_POP;
2753         PL_op = oldop;
2754         JMPENV_JUMP(ret);
2755         /* NOTREACHED */
2756     }
2757     JMPENV_POP;
2758     PL_op = oldop;
2759     return Nullop;
2760 }
2761
2762 OP *
2763 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2764 /* sv Text to convert to OP tree. */
2765 /* startop op_free() this to undo. */
2766 /* code Short string id of the caller. */
2767 {
2768     dVAR; dSP;                          /* Make POPBLOCK work. */
2769     PERL_CONTEXT *cx;
2770     SV **newsp;
2771     I32 gimme = G_VOID;
2772     I32 optype;
2773     OP dummy;
2774     OP *rop;
2775     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2776     char *tmpbuf = tbuf;
2777     char *safestr;
2778     int runtime;
2779     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2780
2781     ENTER;
2782     lex_start(sv);
2783     SAVETMPS;
2784     /* switch to eval mode */
2785
2786     if (IN_PERL_COMPILETIME) {
2787         SAVECOPSTASH_FREE(&PL_compiling);
2788         CopSTASH_set(&PL_compiling, PL_curstash);
2789     }
2790     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2791         SV * const sv = sv_newmortal();
2792         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2793                        code, (unsigned long)++PL_evalseq,
2794                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2795         tmpbuf = SvPVX(sv);
2796     }
2797     else
2798         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2799     SAVECOPFILE_FREE(&PL_compiling);
2800     CopFILE_set(&PL_compiling, tmpbuf+2);
2801     SAVECOPLINE(&PL_compiling);
2802     CopLINE_set(&PL_compiling, 1);
2803     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2804        deleting the eval's FILEGV from the stash before gv_check() runs
2805        (i.e. before run-time proper). To work around the coredump that
2806        ensues, we always turn GvMULTI_on for any globals that were
2807        introduced within evals. See force_ident(). GSAR 96-10-12 */
2808     safestr = savepv(tmpbuf);
2809     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2810     SAVEHINTS();
2811 #ifdef OP_IN_REGISTER
2812     PL_opsave = op;
2813 #else
2814     SAVEVPTR(PL_op);
2815 #endif
2816
2817     /* we get here either during compilation, or via pp_regcomp at runtime */
2818     runtime = IN_PERL_RUNTIME;
2819     if (runtime)
2820         runcv = find_runcv(NULL);
2821
2822     PL_op = &dummy;
2823     PL_op->op_type = OP_ENTEREVAL;
2824     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2825     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2826     PUSHEVAL(cx, 0, Nullgv);
2827
2828     if (runtime)
2829         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2830     else
2831         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2832     POPBLOCK(cx,PL_curpm);
2833     POPEVAL(cx);
2834
2835     (*startop)->op_type = OP_NULL;
2836     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2837     lex_end();
2838     /* XXX DAPM do this properly one year */
2839     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2840     LEAVE;
2841     if (IN_PERL_COMPILETIME)
2842         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2843 #ifdef OP_IN_REGISTER
2844     op = PL_opsave;
2845 #endif
2846     PERL_UNUSED_VAR(newsp);
2847     PERL_UNUSED_VAR(optype);
2848
2849     return rop;
2850 }
2851
2852
2853 /*
2854 =for apidoc find_runcv
2855
2856 Locate the CV corresponding to the currently executing sub or eval.
2857 If db_seqp is non_null, skip CVs that are in the DB package and populate
2858 *db_seqp with the cop sequence number at the point that the DB:: code was
2859 entered. (allows debuggers to eval in the scope of the breakpoint rather
2860 than in in the scope of the debugger itself).
2861
2862 =cut
2863 */
2864
2865 CV*
2866 Perl_find_runcv(pTHX_ U32 *db_seqp)
2867 {
2868     PERL_SI      *si;
2869
2870     if (db_seqp)
2871         *db_seqp = PL_curcop->cop_seq;
2872     for (si = PL_curstackinfo; si; si = si->si_prev) {
2873         I32 ix;
2874         for (ix = si->si_cxix; ix >= 0; ix--) {
2875             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2876             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2877                 CV * const cv = cx->blk_sub.cv;
2878                 /* skip DB:: code */
2879                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2880                     *db_seqp = cx->blk_oldcop->cop_seq;
2881                     continue;
2882                 }
2883                 return cv;
2884             }
2885             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2886                 return PL_compcv;
2887         }
2888     }
2889     return PL_main_cv;
2890 }
2891
2892
2893 /* Compile a require/do, an eval '', or a /(?{...})/.
2894  * In the last case, startop is non-null, and contains the address of
2895  * a pointer that should be set to the just-compiled code.
2896  * outside is the lexically enclosing CV (if any) that invoked us.
2897  */
2898
2899 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2900 STATIC OP *
2901 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2902 {
2903     dVAR; dSP;
2904     OP *saveop = PL_op;
2905
2906     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2907                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2908                   : EVAL_INEVAL);
2909
2910     PUSHMARK(SP);
2911
2912     SAVESPTR(PL_compcv);
2913     PL_compcv = (CV*)NEWSV(1104,0);
2914     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2915     CvEVAL_on(PL_compcv);
2916     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2917     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2918
2919     CvOUTSIDE_SEQ(PL_compcv) = seq;
2920     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2921
2922     /* set up a scratch pad */
2923
2924     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2925
2926
2927     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2928
2929     /* make sure we compile in the right package */
2930
2931     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2932         SAVESPTR(PL_curstash);
2933         PL_curstash = CopSTASH(PL_curcop);
2934     }
2935     SAVESPTR(PL_beginav);
2936     PL_beginav = newAV();
2937     SAVEFREESV(PL_beginav);
2938     SAVEI32(PL_error_count);
2939
2940     /* try to compile it */
2941
2942     PL_eval_root = Nullop;
2943     PL_error_count = 0;
2944     PL_curcop = &PL_compiling;
2945     PL_curcop->cop_arybase = 0;
2946     if (saveop && saveop->op_flags & OPf_SPECIAL)
2947         PL_in_eval |= EVAL_KEEPERR;
2948     else
2949         sv_setpvn(ERRSV,"",0);
2950     if (yyparse() || PL_error_count || !PL_eval_root) {
2951         SV **newsp;                     /* Used by POPBLOCK. */
2952         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2953         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2954         const char *msg;
2955
2956         PL_op = saveop;
2957         if (PL_eval_root) {
2958             op_free(PL_eval_root);
2959             PL_eval_root = Nullop;
2960         }
2961         SP = PL_stack_base + POPMARK;           /* pop original mark */
2962         if (!startop) {
2963             POPBLOCK(cx,PL_curpm);
2964             POPEVAL(cx);
2965         }
2966         lex_end();
2967         LEAVE;
2968
2969         msg = SvPVx_nolen_const(ERRSV);
2970         if (optype == OP_REQUIRE) {
2971             const SV * const nsv = cx->blk_eval.old_namesv;
2972             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2973                           &PL_sv_undef, 0);
2974             DIE(aTHX_ "%sCompilation failed in require",
2975                 *msg ? msg : "Unknown error\n");
2976         }
2977         else if (startop) {
2978             POPBLOCK(cx,PL_curpm);
2979             POPEVAL(cx);
2980             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2981                        (*msg ? msg : "Unknown error\n"));
2982         }
2983         else {
2984             if (!*msg) {
2985                 sv_setpv(ERRSV, "Compilation error");
2986             }
2987         }
2988         PERL_UNUSED_VAR(newsp);
2989         RETPUSHUNDEF;
2990     }
2991     CopLINE_set(&PL_compiling, 0);
2992     if (startop) {
2993         *startop = PL_eval_root;
2994     } else
2995         SAVEFREEOP(PL_eval_root);
2996
2997     /* Set the context for this new optree.
2998      * If the last op is an OP_REQUIRE, force scalar context.
2999      * Otherwise, propagate the context from the eval(). */
3000     if (PL_eval_root->op_type == OP_LEAVEEVAL
3001             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3002             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3003             == OP_REQUIRE)
3004         scalar(PL_eval_root);
3005     else if (gimme & G_VOID)
3006         scalarvoid(PL_eval_root);
3007     else if (gimme & G_ARRAY)
3008         list(PL_eval_root);
3009     else
3010         scalar(PL_eval_root);
3011
3012     DEBUG_x(dump_eval());
3013
3014     /* Register with debugger: */
3015     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3016         CV *cv = get_cv("DB::postponed", FALSE);
3017         if (cv) {
3018             dSP;
3019             PUSHMARK(SP);
3020             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3021             PUTBACK;
3022             call_sv((SV*)cv, G_DISCARD);
3023         }
3024     }
3025
3026     /* compiled okay, so do it */
3027
3028     CvDEPTH(PL_compcv) = 1;
3029     SP = PL_stack_base + POPMARK;               /* pop original mark */
3030     PL_op = saveop;                     /* The caller may need it. */
3031     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3032
3033     RETURNOP(PL_eval_start);
3034 }
3035
3036 STATIC PerlIO *
3037 S_doopen_pm(pTHX_ const char *name, const char *mode)
3038 {
3039 #ifndef PERL_DISABLE_PMC
3040     const STRLEN namelen = strlen(name);
3041     PerlIO *fp;
3042
3043     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3044         SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3045         const char * const pmc = SvPV_nolen_const(pmcsv);
3046         Stat_t pmcstat;
3047         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3048             fp = PerlIO_open(name, mode);
3049         }
3050         else {
3051             Stat_t pmstat;
3052             if (PerlLIO_stat(name, &pmstat) < 0 ||
3053                 pmstat.st_mtime < pmcstat.st_mtime)
3054             {
3055                 fp = PerlIO_open(pmc, mode);
3056             }
3057             else {
3058                 fp = PerlIO_open(name, mode);
3059             }
3060         }
3061         SvREFCNT_dec(pmcsv);
3062     }
3063     else {
3064         fp = PerlIO_open(name, mode);
3065     }
3066     return fp;
3067 #else
3068     return PerlIO_open(name, mode);
3069 #endif /* !PERL_DISABLE_PMC */
3070 }
3071
3072 PP(pp_require)
3073 {
3074     dVAR; dSP;
3075     register PERL_CONTEXT *cx;
3076     SV *sv;
3077     const char *name;
3078     STRLEN len;
3079     const char *tryname = Nullch;
3080     SV *namesv = Nullsv;
3081     SV** svp;
3082     const I32 gimme = GIMME_V;
3083     PerlIO *tryrsfp = 0;
3084     int filter_has_file = 0;
3085     GV *filter_child_proc = 0;
3086     SV *filter_state = 0;
3087     SV *filter_sub = 0;
3088     SV *hook_sv = 0;
3089     SV *encoding;
3090     OP *op;
3091
3092     sv = POPs;
3093     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3094         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3095                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3096                         "v-string in use/require non-portable");
3097
3098         sv = new_version(sv);
3099         if (!sv_derived_from(PL_patchlevel, "version"))
3100             (void *)upg_version(PL_patchlevel);
3101         if ( vcmp(sv,PL_patchlevel) > 0 )
3102             DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3103                 vnormal(sv), vnormal(PL_patchlevel));
3104
3105             RETPUSHYES;
3106     }
3107     name = SvPV_const(sv, len);
3108     if (!(name && len > 0 && *name))
3109         DIE(aTHX_ "Null filename used");
3110     TAINT_PROPER("require");
3111     if (PL_op->op_type == OP_REQUIRE &&
3112        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3113        if (*svp != &PL_sv_undef)
3114            RETPUSHYES;
3115        else
3116            DIE(aTHX_ "Compilation failed in require");
3117     }
3118
3119     /* prepare to compile file */
3120
3121     if (path_is_absolute(name)) {
3122         tryname = name;
3123         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3124     }
3125 #ifdef MACOS_TRADITIONAL
3126     if (!tryrsfp) {
3127         char newname[256];
3128
3129         MacPerl_CanonDir(name, newname, 1);
3130         if (path_is_absolute(newname)) {
3131             tryname = newname;
3132             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3133         }
3134     }
3135 #endif
3136     if (!tryrsfp) {
3137         AV *ar = GvAVn(PL_incgv);
3138         I32 i;
3139 #ifdef VMS
3140         char *unixname;
3141         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3142 #endif
3143         {
3144             namesv = NEWSV(806, 0);
3145             for (i = 0; i <= AvFILL(ar); i++) {
3146                 SV *dirsv = *av_fetch(ar, i, TRUE);
3147
3148                 if (SvROK(dirsv)) {
3149                     int count;
3150                     SV *loader = dirsv;
3151
3152                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3153                         && !sv_isobject(loader))
3154                     {
3155                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3156                     }
3157
3158                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3159                                    PTR2UV(SvRV(dirsv)), name);
3160                     tryname = SvPVX_const(namesv);
3161                     tryrsfp = 0;
3162
3163                     ENTER;
3164                     SAVETMPS;
3165                     EXTEND(SP, 2);
3166
3167                     PUSHMARK(SP);
3168                     PUSHs(dirsv);
3169                     PUSHs(sv);
3170                     PUTBACK;
3171                     if (sv_isobject(loader))
3172                         count = call_method("INC", G_ARRAY);
3173                     else
3174                         count = call_sv(loader, G_ARRAY);
3175                     SPAGAIN;
3176
3177                     if (count > 0) {
3178                         int i = 0;
3179                         SV *arg;
3180
3181                         SP -= count - 1;
3182                         arg = SP[i++];
3183
3184                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3185                             arg = SvRV(arg);
3186                         }
3187
3188                         if (SvTYPE(arg) == SVt_PVGV) {
3189                             IO *io = GvIO((GV *)arg);
3190
3191                             ++filter_has_file;
3192
3193                             if (io) {
3194                                 tryrsfp = IoIFP(io);
3195                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3196                                     /* reading from a child process doesn't
3197                                        nest -- when returning from reading
3198                                        the inner module, the outer one is
3199                                        unreadable (closed?)  I've tried to
3200                                        save the gv to manage the lifespan of
3201                                        the pipe, but this didn't help. XXX */
3202                                     filter_child_proc = (GV *)arg;
3203                                     (void)SvREFCNT_inc(filter_child_proc);
3204                                 }
3205                                 else {
3206                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3207                                         PerlIO_close(IoOFP(io));
3208                                     }
3209                                     IoIFP(io) = Nullfp;
3210                                     IoOFP(io) = Nullfp;
3211                                 }
3212                             }
3213
3214                             if (i < count) {
3215                                 arg = SP[i++];
3216                             }
3217                         }
3218
3219                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3220                             filter_sub = arg;
3221                             (void)SvREFCNT_inc(filter_sub);
3222
3223                             if (i < count) {
3224                                 filter_state = SP[i];
3225                                 (void)SvREFCNT_inc(filter_state);
3226                             }
3227
3228                             if (tryrsfp == 0) {
3229                                 tryrsfp = PerlIO_open("/dev/null",
3230                                                       PERL_SCRIPT_MODE);
3231                             }
3232                         }
3233                         SP--;
3234                     }
3235
3236                     PUTBACK;
3237                     FREETMPS;
3238                     LEAVE;
3239
3240                     if (tryrsfp) {
3241                         hook_sv = dirsv;
3242                         break;
3243                     }
3244
3245                     filter_has_file = 0;
3246                     if (filter_child_proc) {
3247                         SvREFCNT_dec(filter_child_proc);
3248                         filter_child_proc = 0;
3249                     }
3250                     if (filter_state) {
3251                         SvREFCNT_dec(filter_state);
3252                         filter_state = 0;
3253                     }
3254                     if (filter_sub) {
3255                         SvREFCNT_dec(filter_sub);
3256                         filter_sub = 0;
3257                     }
3258                 }
3259                 else {
3260                   if (!path_is_absolute(name)
3261 #ifdef MACOS_TRADITIONAL
3262                         /* We consider paths of the form :a:b ambiguous and interpret them first
3263                            as global then as local
3264                         */
3265                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3266 #endif
3267                   ) {
3268                     const char *dir = SvPVx_nolen_const(dirsv);
3269 #ifdef MACOS_TRADITIONAL
3270                     char buf1[256];
3271                     char buf2[256];
3272
3273                     MacPerl_CanonDir(name, buf2, 1);
3274                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3275 #else
3276 #  ifdef VMS
3277                     char *unixdir;
3278                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3279                         continue;
3280                     sv_setpv(namesv, unixdir);
3281                     sv_catpv(namesv, unixname);
3282 #  else
3283 #    ifdef SYMBIAN
3284                     if (PL_origfilename[0] &&
3285                         PL_origfilename[1] == ':' &&
3286                         !(dir[0] && dir[1] == ':'))
3287                         Perl_sv_setpvf(aTHX_ namesv,
3288                                        "%c:%s\\%s",
3289                                        PL_origfilename[0],
3290                                        dir, name);
3291                     else
3292                         Perl_sv_setpvf(aTHX_ namesv,
3293                                        "%s\\%s",
3294                                        dir, name);
3295 #    else
3296                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3297 #    endif
3298 #  endif
3299 #endif
3300                     TAINT_PROPER("require");
3301                     tryname = SvPVX_const(namesv);
3302                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3303                     if (tryrsfp) {
3304                         if (tryname[0] == '.' && tryname[1] == '/')
3305                             tryname += 2;
3306                         break;
3307                     }
3308                   }
3309                 }
3310             }
3311         }
3312     }
3313     SAVECOPFILE_FREE(&PL_compiling);
3314     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3315     SvREFCNT_dec(namesv);
3316     if (!tryrsfp) {
3317         if (PL_op->op_type == OP_REQUIRE) {
3318             const char *msgstr = name;
3319             if (namesv) {                       /* did we lookup @INC? */
3320                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3321                 SV *dirmsgsv = NEWSV(0, 0);
3322                 AV *ar = GvAVn(PL_incgv);
3323                 I32 i;
3324                 sv_catpvn(msg, " in @INC", 8);
3325                 if (instr(SvPVX_const(msg), ".h "))
3326                     sv_catpv(msg, " (change .h to .ph maybe?)");
3327                 if (instr(SvPVX_const(msg), ".ph "))
3328                     sv_catpv(msg, " (did you run h2ph?)");
3329                 sv_catpv(msg, " (@INC contains:");
3330                 for (i = 0; i <= AvFILL(ar); i++) {
3331                     const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3332                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3333                     sv_catsv(msg, dirmsgsv);
3334                 }
3335                 sv_catpvn(msg, ")", 1);
3336                 SvREFCNT_dec(dirmsgsv);
3337                 msgstr = SvPV_nolen_const(msg);
3338             }
3339             DIE(aTHX_ "Can't locate %s", msgstr);
3340         }
3341
3342         RETPUSHUNDEF;
3343     }
3344     else
3345         SETERRNO(0, SS_NORMAL);
3346
3347     /* Assume success here to prevent recursive requirement. */
3348     len = strlen(name);
3349     /* Check whether a hook in @INC has already filled %INC */
3350     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3351         (void)hv_store(GvHVn(PL_incgv), name, len,
3352                        (hook_sv ? SvREFCNT_inc(hook_sv)
3353                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3354                        0 );
3355     }
3356
3357     ENTER;
3358     SAVETMPS;
3359     lex_start(sv_2mortal(newSVpvn("",0)));
3360     SAVEGENERICSV(PL_rsfp_filters);
3361     PL_rsfp_filters = Nullav;
3362
3363     PL_rsfp = tryrsfp;
3364     SAVEHINTS();
3365     PL_hints = 0;
3366     SAVESPTR(PL_compiling.cop_warnings);
3367     if (PL_dowarn & G_WARN_ALL_ON)
3368         PL_compiling.cop_warnings = pWARN_ALL ;
3369     else if (PL_dowarn & G_WARN_ALL_OFF)
3370         PL_compiling.cop_warnings = pWARN_NONE ;
3371     else if (PL_taint_warn)
3372         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3373     else
3374         PL_compiling.cop_warnings = pWARN_STD ;
3375     SAVESPTR(PL_compiling.cop_io);
3376     PL_compiling.cop_io = Nullsv;
3377
3378     if (filter_sub || filter_child_proc) {
3379         SV *datasv = filter_add(run_user_filter, Nullsv);
3380         IoLINES(datasv) = filter_has_file;
3381         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3382         IoTOP_GV(datasv) = (GV *)filter_state;
3383         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3384     }
3385
3386     /* switch to eval mode */
3387     PUSHBLOCK(cx, CXt_EVAL, SP);
3388     PUSHEVAL(cx, name, Nullgv);
3389     cx->blk_eval.retop = PL_op->op_next;
3390
3391     SAVECOPLINE(&PL_compiling);
3392     CopLINE_set(&PL_compiling, 0);
3393
3394     PUTBACK;
3395
3396     /* Store and reset encoding. */
3397     encoding = PL_encoding;
3398     PL_encoding = Nullsv;
3399
3400     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3401
3402     /* Restore encoding. */
3403     PL_encoding = encoding;
3404
3405     return op;
3406 }
3407
3408 PP(pp_dofile)
3409 {
3410     return pp_require();
3411 }
3412
3413 PP(pp_entereval)
3414 {
3415     dVAR; dSP;
3416     register PERL_CONTEXT *cx;
3417     dPOPss;
3418     const I32 gimme = GIMME_V, was = PL_sub_generation;
3419     char tbuf[TYPE_DIGITS(long) + 12];
3420     char *tmpbuf = tbuf;
3421     char *safestr;
3422     STRLEN len;
3423     OP *ret;
3424     CV* runcv;
3425     U32 seq;
3426
3427     if (!SvPV_const(sv,len))
3428         RETPUSHUNDEF;
3429     TAINT_PROPER("eval");
3430
3431     ENTER;
3432     lex_start(sv);
3433     SAVETMPS;
3434
3435     /* switch to eval mode */
3436
3437     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3438         SV *sv = sv_newmortal();
3439         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3440                        (unsigned long)++PL_evalseq,
3441                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3442         tmpbuf = SvPVX(sv);
3443     }
3444     else
3445         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3446     SAVECOPFILE_FREE(&PL_compiling);
3447     CopFILE_set(&PL_compiling, tmpbuf+2);
3448     SAVECOPLINE(&PL_compiling);
3449     CopLINE_set(&PL_compiling, 1);
3450     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3451        deleting the eval's FILEGV from the stash before gv_check() runs
3452        (i.e. before run-time proper). To work around the coredump that
3453        ensues, we always turn GvMULTI_on for any globals that were
3454        introduced within evals. See force_ident(). GSAR 96-10-12 */
3455     safestr = savepv(tmpbuf);
3456     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3457     SAVEHINTS();
3458     PL_hints = PL_op->op_targ;
3459     SAVESPTR(PL_compiling.cop_warnings);
3460     if (specialWARN(PL_curcop->cop_warnings))
3461         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3462     else {
3463         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3464         SAVEFREESV(PL_compiling.cop_warnings);
3465     }
3466     SAVESPTR(PL_compiling.cop_io);
3467     if (specialCopIO(PL_curcop->cop_io))
3468         PL_compiling.cop_io = PL_curcop->cop_io;
3469     else {
3470         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3471         SAVEFREESV(PL_compiling.cop_io);
3472     }
3473     /* special case: an eval '' executed within the DB package gets lexically
3474      * placed in the first non-DB CV rather than the current CV - this
3475      * allows the debugger to execute code, find lexicals etc, in the
3476      * scope of the code being debugged. Passing &seq gets find_runcv
3477      * to do the dirty work for us */
3478     runcv = find_runcv(&seq);
3479
3480     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3481     PUSHEVAL(cx, 0, Nullgv);
3482     cx->blk_eval.retop = PL_op->op_next;
3483
3484     /* prepare to compile string */
3485
3486     if (PERLDB_LINE && PL_curstash != PL_debstash)
3487         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3488     PUTBACK;
3489     ret = doeval(gimme, NULL, runcv, seq);
3490     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3491         && ret != PL_op->op_next) {     /* Successive compilation. */
3492         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3493     }
3494     return DOCATCH(ret);
3495 }
3496
3497 PP(pp_leaveeval)
3498 {
3499     dVAR; dSP;
3500     register SV **mark;
3501     SV **newsp;
3502     PMOP *newpm;
3503     I32 gimme;
3504     register PERL_CONTEXT *cx;
3505     OP *retop;
3506     const U8 save_flags = PL_op -> op_flags;
3507     I32 optype;
3508
3509     POPBLOCK(cx,newpm);
3510     POPEVAL(cx);
3511     retop = cx->blk_eval.retop;
3512
3513     TAINT_NOT;
3514     if (gimme == G_VOID)
3515         MARK = newsp;
3516     else if (gimme == G_SCALAR) {
3517         MARK = newsp + 1;
3518         if (MARK <= SP) {
3519             if (SvFLAGS(TOPs) & SVs_TEMP)
3520                 *MARK = TOPs;
3521             else
3522                 *MARK = sv_mortalcopy(TOPs);
3523         }
3524         else {
3525             MEXTEND(mark,0);
3526             *MARK = &PL_sv_undef;
3527         }
3528         SP = MARK;
3529     }
3530     else {
3531         /* in case LEAVE wipes old return values */
3532         for (mark = newsp + 1; mark <= SP; mark++) {
3533             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3534                 *mark = sv_mortalcopy(*mark);
3535                 TAINT_NOT;      /* Each item is independent */
3536             }
3537         }
3538     }
3539     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3540
3541 #ifdef DEBUGGING
3542     assert(CvDEPTH(PL_compcv) == 1);
3543 #endif
3544     CvDEPTH(PL_compcv) = 0;
3545     lex_end();
3546
3547     if (optype == OP_REQUIRE &&
3548         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3549     {
3550         /* Unassume the success we assumed earlier. */
3551         SV * const nsv = cx->blk_eval.old_namesv;
3552         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3553         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3554         /* die_where() did LEAVE, or we won't be here */
3555     }
3556     else {
3557         LEAVE;
3558         if (!(save_flags & OPf_SPECIAL))
3559             sv_setpvn(ERRSV,"",0);
3560     }
3561
3562     RETURNOP(retop);
3563 }
3564
3565 PP(pp_entertry)
3566 {
3567     dVAR; dSP;
3568     register PERL_CONTEXT *cx;
3569     const I32 gimme = GIMME_V;
3570
3571     ENTER;
3572     SAVETMPS;
3573
3574     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3575     PUSHEVAL(cx, 0, 0);
3576     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3577
3578     PL_in_eval = EVAL_INEVAL;
3579     sv_setpvn(ERRSV,"",0);
3580     PUTBACK;
3581     return DOCATCH(PL_op->op_next);
3582 }
3583
3584 PP(pp_leavetry)
3585 {
3586     dVAR; dSP;
3587     register SV **mark;
3588     SV **newsp;
3589     PMOP *newpm;
3590     I32 gimme;
3591     register PERL_CONTEXT *cx;
3592     I32 optype;
3593
3594     POPBLOCK(cx,newpm);
3595     POPEVAL(cx);
3596     PERL_UNUSED_VAR(optype);
3597
3598     TAINT_NOT;
3599     if (gimme == G_VOID)
3600         SP = newsp;
3601     else if (gimme == G_SCALAR) {
3602         MARK = newsp + 1;
3603         if (MARK <= SP) {
3604             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3605                 *MARK = TOPs;
3606             else
3607                 *MARK = sv_mortalcopy(TOPs);
3608         }
3609         else {
3610             MEXTEND(mark,0);
3611             *MARK = &PL_sv_undef;
3612         }
3613         SP = MARK;
3614     }
3615     else {
3616         /* in case LEAVE wipes old return values */
3617         for (mark = newsp + 1; mark <= SP; mark++) {
3618             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3619                 *mark = sv_mortalcopy(*mark);
3620                 TAINT_NOT;      /* Each item is independent */
3621             }
3622         }
3623     }
3624     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3625
3626     LEAVE;
3627     sv_setpvn(ERRSV,"",0);
3628     RETURN;
3629 }
3630
3631 STATIC OP *
3632 S_doparseform(pTHX_ SV *sv)
3633 {
3634     STRLEN len;
3635     register char *s = SvPV_force(sv, len);
3636     register char *send = s + len;
3637     register char *base = Nullch;
3638     register I32 skipspaces = 0;
3639     bool noblank   = FALSE;
3640     bool repeat    = FALSE;
3641     bool postspace = FALSE;
3642     U32 *fops;
3643     register U32 *fpc;
3644     U32 *linepc = 0;
3645     register I32 arg;
3646     bool ischop;
3647     bool unchopnum = FALSE;
3648     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3649
3650     if (len == 0)
3651         Perl_croak(aTHX_ "Null picture in formline");
3652
3653     /* estimate the buffer size needed */
3654     for (base = s; s <= send; s++) {
3655         if (*s == '\n' || *s == '@' || *s == '^')
3656             maxops += 10;
3657     }
3658     s = base;
3659     base = Nullch;
3660
3661     New(804, fops, maxops, U32);
3662     fpc = fops;
3663
3664     if (s < send) {
3665         linepc = fpc;
3666         *fpc++ = FF_LINEMARK;
3667         noblank = repeat = FALSE;
3668         base = s;
3669     }
3670
3671     while (s <= send) {
3672         switch (*s++) {
3673         default:
3674             skipspaces = 0;
3675             continue;
3676
3677         case '~':
3678             if (*s == '~') {
3679                 repeat = TRUE;
3680                 *s = ' ';
3681             }
3682             noblank = TRUE;
3683             s[-1] = ' ';
3684             /* FALL THROUGH */
3685         case ' ': case '\t':
3686             skipspaces++;
3687             continue;
3688         case 0:
3689             if (s < send) {
3690                 skipspaces = 0;
3691                 continue;
3692             } /* else FALL THROUGH */
3693         case '\n':
3694             arg = s - base;
3695             skipspaces++;
3696             arg -= skipspaces;
3697             if (arg) {
3698                 if (postspace)
3699                     *fpc++ = FF_SPACE;
3700                 *fpc++ = FF_LITERAL;
3701                 *fpc++ = (U16)arg;
3702             }
3703             postspace = FALSE;
3704             if (s <= send)
3705                 skipspaces--;
3706             if (skipspaces) {
3707                 *fpc++ = FF_SKIP;
3708                 *fpc++ = (U16)skipspaces;
3709             }
3710             skipspaces = 0;
3711             if (s <= send)
3712                 *fpc++ = FF_NEWLINE;
3713             if (noblank) {
3714                 *fpc++ = FF_BLANK;
3715                 if (repeat)
3716                     arg = fpc - linepc + 1;
3717                 else
3718                     arg = 0;
3719                 *fpc++ = (U16)arg;
3720             }
3721             if (s < send) {
3722                 linepc = fpc;
3723                 *fpc++ = FF_LINEMARK;
3724                 noblank = repeat = FALSE;
3725                 base = s;
3726             }
3727             else
3728                 s++;
3729             continue;
3730
3731         case '@':
3732         case '^':
3733             ischop = s[-1] == '^';
3734
3735             if (postspace) {
3736                 *fpc++ = FF_SPACE;
3737                 postspace = FALSE;
3738             }
3739             arg = (s - base) - 1;
3740             if (arg) {
3741                 *fpc++ = FF_LITERAL;
3742                 *fpc++ = (U16)arg;
3743             }
3744
3745             base = s - 1;
3746             *fpc++ = FF_FETCH;
3747             if (*s == '*') {
3748                 s++;
3749                 *fpc++ = 2;  /* skip the @* or ^* */
3750                 if (ischop) {
3751                     *fpc++ = FF_LINESNGL;
3752                     *fpc++ = FF_CHOP;
3753                 } else
3754                     *fpc++ = FF_LINEGLOB;
3755             }
3756             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3757                 arg = ischop ? 512 : 0;
3758                 base = s - 1;
3759                 while (*s == '#')
3760                     s++;
3761                 if (*s == '.') {
3762                     const char * const f = ++s;
3763                     while (*s == '#')
3764                         s++;
3765                     arg |= 256 + (s - f);
3766                 }
3767                 *fpc++ = s - base;              /* fieldsize for FETCH */
3768                 *fpc++ = FF_DECIMAL;
3769                 *fpc++ = (U16)arg;
3770                 unchopnum |= ! ischop;
3771             }
3772             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3773                 arg = ischop ? 512 : 0;
3774                 base = s - 1;
3775                 s++;                                /* skip the '0' first */
3776                 while (*s == '#')
3777                     s++;
3778                 if (*s == '.') {
3779                     const char * const f = ++s;
3780                     while (*s == '#')
3781                         s++;
3782                     arg |= 256 + (s - f);
3783                 }
3784                 *fpc++ = s - base;                /* fieldsize for FETCH */
3785                 *fpc++ = FF_0DECIMAL;
3786                 *fpc++ = (U16)arg;
3787                 unchopnum |= ! ischop;
3788             }
3789             else {
3790                 I32 prespace = 0;
3791                 bool ismore = FALSE;
3792
3793                 if (*s == '>') {
3794                     while (*++s == '>') ;
3795                     prespace = FF_SPACE;
3796                 }
3797                 else if (*s == '|') {
3798                     while (*++s == '|') ;
3799                     prespace = FF_HALFSPACE;
3800                     postspace = TRUE;
3801                 }
3802                 else {
3803                     if (*s == '<')
3804                         while (*++s == '<') ;
3805                     postspace = TRUE;
3806                 }
3807                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3808                     s += 3;
3809                     ismore = TRUE;
3810                 }
3811                 *fpc++ = s - base;              /* fieldsize for FETCH */
3812
3813                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3814
3815                 if (prespace)
3816                     *fpc++ = (U16)prespace;
3817                 *fpc++ = FF_ITEM;
3818                 if (ismore)
3819                     *fpc++ = FF_MORE;
3820                 if (ischop)
3821                     *fpc++ = FF_CHOP;
3822             }
3823             base = s;
3824             skipspaces = 0;
3825             continue;
3826         }
3827     }
3828     *fpc++ = FF_END;
3829
3830     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3831     arg = fpc - fops;
3832     { /* need to jump to the next word */
3833         int z;
3834         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3835         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3836         s = SvPVX(sv) + SvCUR(sv) + z;
3837     }
3838     Copy(fops, s, arg, U32);
3839     Safefree(fops);
3840     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3841     SvCOMPILED_on(sv);
3842
3843     if (unchopnum && repeat)
3844         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3845     return 0;
3846 }
3847
3848
3849 STATIC bool
3850 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3851 {
3852     /* Can value be printed in fldsize chars, using %*.*f ? */
3853     NV pwr = 1;
3854     NV eps = 0.5;
3855     bool res = FALSE;
3856     int intsize = fldsize - (value < 0 ? 1 : 0);
3857
3858     if (frcsize & 256)
3859         intsize--;
3860     frcsize &= 255;
3861     intsize -= frcsize;
3862
3863     while (intsize--) pwr *= 10.0;
3864     while (frcsize--) eps /= 10.0;
3865
3866     if( value >= 0 ){
3867         if (value + eps >= pwr)
3868             res = TRUE;
3869     } else {
3870         if (value - eps <= -pwr)
3871             res = TRUE;
3872     }
3873     return res;
3874 }
3875
3876 static I32
3877 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3878 {
3879     dVAR;
3880     SV *datasv = FILTER_DATA(idx);
3881     const int filter_has_file = IoLINES(datasv);
3882     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3883     SV *filter_state = (SV *)IoTOP_GV(datasv);
3884     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3885     int len = 0;
3886
3887     /* I was having segfault trouble under Linux 2.2.5 after a
3888        parse error occured.  (Had to hack around it with a test
3889        for PL_error_count == 0.)  Solaris doesn't segfault --
3890        not sure where the trouble is yet.  XXX */
3891
3892     if (filter_has_file) {
3893         len = FILTER_READ(idx+1, buf_sv, maxlen);
3894     }
3895
3896     if (filter_sub && len >= 0) {
3897         dSP;
3898         int count;
3899
3900         ENTER;
3901         SAVE_DEFSV;
3902         SAVETMPS;
3903         EXTEND(SP, 2);
3904
3905         DEFSV = buf_sv;
3906         PUSHMARK(SP);
3907         PUSHs(sv_2mortal(newSViv(maxlen)));
3908         if (filter_state) {
3909             PUSHs(filter_state);
3910         }
3911         PUTBACK;
3912         count = call_sv(filter_sub, G_SCALAR);
3913         SPAGAIN;
3914
3915         if (count > 0) {
3916             SV *out = POPs;
3917             if (SvOK(out)) {
3918                 len = SvIV(out);
3919             }
3920         }
3921
3922         PUTBACK;
3923         FREETMPS;
3924         LEAVE;
3925     }
3926
3927     if (len <= 0) {
3928         IoLINES(datasv) = 0;
3929         if (filter_child_proc) {
3930             SvREFCNT_dec(filter_child_proc);
3931             IoFMT_GV(datasv) = Nullgv;
3932         }
3933         if (filter_state) {
3934             SvREFCNT_dec(filter_state);
3935             IoTOP_GV(datasv) = Nullgv;
3936         }
3937         if (filter_sub) {
3938             SvREFCNT_dec(filter_sub);
3939             IoBOTTOM_GV(datasv) = Nullgv;
3940         }
3941         filter_del(run_user_filter);
3942     }
3943
3944     return len;
3945 }
3946
3947 /* perhaps someone can come up with a better name for
3948    this?  it is not really "absolute", per se ... */
3949 static bool
3950 S_path_is_absolute(pTHX_ const char *name)
3951 {
3952     if (PERL_FILE_IS_ABSOLUTE(name)
3953 #ifdef MACOS_TRADITIONAL
3954         || (*name == ':'))
3955 #else
3956         || (*name == '.' && (name[1] == '/' ||
3957                              (name[1] == '.' && name[2] == '/'))))
3958 #endif
3959     {
3960         return TRUE;
3961     }
3962     else
3963         return FALSE;
3964 }
3965
3966 /*
3967  * Local variables:
3968  * c-indentation-style: bsd
3969  * c-basic-offset: 4
3970  * indent-tabs-mode: t
3971  * End:
3972  *
3973  * ex: set ts=8 sts=4 sw=4 noet:
3974  */