pp_ctl.c

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