pp_ctl.c

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