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