pp_ctl.c

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