pp_ctl.c

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