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