pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains control-oriented pp ("push/pop") functions that
  23  * execute the opcodes that make up a perl program. A typical pp function
  24  * expects to find its arguments on the stack, and usually pushes its
  25  * results onto the stack, hence the 'pp' terminology. Each OP structure
  26  * contains a pointer to the relevant pp_foo() function.
  27  *
  28  * Control-oriented means things like pp_enteriter() and pp_next(), which
  29  * alter the flow of control of the program.
  30  */
  31
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_PP_CTL_C
  35 #include "perl.h"
  36
  37 #ifndef WORD_ALIGN
  38 #define WORD_ALIGN sizeof(U32)
  39 #endif
  40
  41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  42
  43 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  44
  45 PP(pp_wantarray)
  46 {
  47     dVAR;
  48     dSP;
  49     I32 cxix;
  50     EXTEND(SP, 1);
  51
  52     cxix = dopoptosub(cxstack_ix);
  53     if (cxix < 0)
  54         RETPUSHUNDEF;
  55
  56     switch (cxstack[cxix].blk_gimme) {
  57     case G_ARRAY:
  58         RETPUSHYES;
  59     case G_SCALAR:
  60         RETPUSHNO;
  61     default:
  62         RETPUSHUNDEF;
  63     }
  64 }
  65
  66 PP(pp_regcreset)
  67 {
  68     dVAR;
  69     /* XXXX Should store the old value to allow for tie/overload - and
  70        restore in regcomp, where marked with XXXX. */
  71     PL_reginterp_cnt = 0;
  72     TAINT_NOT;
  73     return NORMAL;
  74 }
  75
  76 PP(pp_regcomp)
  77 {
  78     dVAR;
  79     dSP;
  80     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     SV *tmpstr;
  82     REGEXP *re = NULL;
  83
  84     /* prevent recompiling under /o and ithreads. */
  85 #if defined(USE_ITHREADS)
  86     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  87         if (PL_op->op_flags & OPf_STACKED) {
  88             dMARK;
  89             SP = MARK;
  90         }
  91         else
  92             (void)POPs;
  93         RETURN;
  94     }
  95 #endif
  96
  97 #define tryAMAGICregexp(rx)                     \
  98     STMT_START {                                \
  99         if (SvROK(rx) && SvAMAGIC(rx)) {        \
 100             SV *sv = AMG_CALLun(rx, regexp);    \
 101             if (sv) {                           \
 102                 if (SvROK(sv))                  \
 103                     sv = SvRV(sv);              \
 104                 if (SvTYPE(sv) != SVt_REGEXP)   \
 105                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
 106                 rx = sv;                        \
 107             }                                   \
 108         }                                       \
 109     } STMT_END
 110
 111
 112     if (PL_op->op_flags & OPf_STACKED) {
 113         /* multiple args; concatentate them */
 114         dMARK; dORIGMARK;
 115         tmpstr = PAD_SV(ARGTARG);
 116         sv_setpvs(tmpstr, "");
 117         while (++MARK <= SP) {
 118             SV *msv = *MARK;
 119             if (PL_amagic_generation) {
 120                 SV *sv;
 121
 122                 tryAMAGICregexp(msv);
 123
 124                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
 125                     (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
 126                 {
 127                    sv_setsv(tmpstr, sv);
 128                    continue;
 129                 }
 130             }
 131             sv_catsv(tmpstr, msv);
 132         }
 133         SvSETMAGIC(tmpstr);
 134         SP = ORIGMARK;
 135     }
 136     else {
 137         tmpstr = POPs;
 138         tryAMAGICregexp(tmpstr);
 139     }
 140
 141 #undef tryAMAGICregexp
 142
 143     if (SvROK(tmpstr)) {
 144         SV * const sv = SvRV(tmpstr);
 145         if (SvTYPE(sv) == SVt_REGEXP)
 146             re = (REGEXP*) sv;
 147     }
 148     else if (SvTYPE(tmpstr) == SVt_REGEXP)
 149         re = (REGEXP*) tmpstr;
 150
 151     if (re) {
 152         /* The match's LHS's get-magic might need to access this op's reg-
 153            exp (as is sometimes the case with $';  see bug 70764).  So we
 154            must call get-magic now before we replace the regexp. Hopeful-
 155            ly this hack can be replaced with the approach described at
 156            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
 157            /msg122415.html some day. */
 158         if(pm->op_type == OP_MATCH) {
 159          SV *lhs;
 160          const bool was_tainted = PL_tainted;
 161          if (pm->op_flags & OPf_STACKED)
 162             lhs = TOPs;
 163          else if (pm->op_private & OPpTARGET_MY)
 164             lhs = PAD_SV(pm->op_targ);
 165          else lhs = DEFSV;
 166          SvGETMAGIC(lhs);
 167          /* Restore the previous value of PL_tainted (which may have been
 168             modified by get-magic), to avoid incorrectly setting the
 169             RXf_TAINTED flag further down. */
 170          PL_tainted = was_tainted;
 171         }
 172
 173         re = reg_temp_copy(NULL, re);
 174         ReREFCNT_dec(PM_GETRE(pm));
 175         PM_SETRE(pm, re);
 176     }
 177     else {
 178         STRLEN len;
 179         const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
 180         re = PM_GETRE(pm);
 181         assert (re != (REGEXP*) &PL_sv_undef);
 182
 183         /* Check against the last compiled regexp. */
 184         if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
 185             memNE(RX_PRECOMP(re), t, len))
 186         {
 187             const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
 188             U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
 189             if (re) {
 190                 ReREFCNT_dec(re);
 191 #ifdef USE_ITHREADS
 192                 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
 193 #else
 194                 PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
 195 #endif
 196             } else if (PL_curcop->cop_hints_hash) {
 197                 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
 198                                        "regcomp", 7, 0, 0);
 199                 if (ptr && SvIOK(ptr) && SvIV(ptr))
 200                     eng = INT2PTR(regexp_engine*,SvIV(ptr));
 201             }
 202
 203             if (PL_op->op_flags & OPf_SPECIAL)
 204                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 205
 206             if (DO_UTF8(tmpstr)) {
 207                 assert (SvUTF8(tmpstr));
 208             } else if (SvUTF8(tmpstr)) {
 209                 /* Not doing UTF-8, despite what the SV says. Is this only if
 210                    we're trapped in use 'bytes'?  */
 211                 /* Make a copy of the octet sequence, but without the flag on,
 212                    as the compiler now honours the SvUTF8 flag on tmpstr.  */
 213                 STRLEN len;
 214                 const char *const p = SvPV(tmpstr, len);
 215                 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
 216             }
 217
 218                 if (eng)
 219                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
 220                 else
 221                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
 222
 223             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 224                                            inside tie/overload accessors.  */
 225         }
 226     }
 227
 228     re = PM_GETRE(pm);
 229
 230 #ifndef INCOMPLETE_TAINTS
 231     if (PL_tainting) {
 232         if (PL_tainted)
 233             RX_EXTFLAGS(re) |= RXf_TAINTED;
 234         else
 235             RX_EXTFLAGS(re) &= ~RXf_TAINTED;
 236     }
 237 #endif
 238
 239     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
 240         pm = PL_curpm;
 241
 242
 243 #if !defined(USE_ITHREADS)
 244     /* can't change the optree at runtime either */
 245     /* PMf_KEEP is handled differently under threads to avoid these problems */
 246     if (pm->op_pmflags & PMf_KEEP) {
 247         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 248         cLOGOP->op_first->op_next = PL_op->op_next;
 249     }
 250 #endif
 251     RETURN;
 252 }
 253
 254 PP(pp_substcont)
 255 {
 256     dVAR;
 257     dSP;
 258     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 259     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 260     register SV * const dstr = cx->sb_dstr;
 261     register char *s = cx->sb_s;
 262     register char *m = cx->sb_m;
 263     char *orig = cx->sb_orig;
 264     register REGEXP * const rx = cx->sb_rx;
 265     SV *nsv = NULL;
 266     REGEXP *old = PM_GETRE(pm);
 267
 268     PERL_ASYNC_CHECK();
 269
 270     if(old != rx) {
 271         if(old)
 272             ReREFCNT_dec(old);
 273         PM_SETRE(pm,ReREFCNT_inc(rx));
 274     }
 275
 276     rxres_restore(&cx->sb_rxres, rx);
 277     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 278
 279     if (cx->sb_iters++) {
 280         const I32 saviters = cx->sb_iters;
 281         if (cx->sb_iters > cx->sb_maxiters)
 282             DIE(aTHX_ "Substitution loop");
 283
 284         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
 285
 286         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 287             cx->sb_rxtainted |= 2;
 288         sv_catsv_nomg(dstr, POPs);
 289         /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
 290         s -= RX_GOFS(rx);
 291
 292         /* Are we done */
 293         if (CxONCE(cx) || s < orig ||
 294                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 295                              (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
 296                              ((cx->sb_rflags & REXEC_COPY_STR)
 297                               ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 298                               : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 299         {
 300             SV * const targ = cx->sb_targ;
 301
 302             assert(cx->sb_strend >= s);
 303             if(cx->sb_strend > s) {
 304                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 305                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 306                  else
 307                       sv_catpvn(dstr, s, cx->sb_strend - s);
 308             }
 309             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 310
 311 #ifdef PERL_OLD_COPY_ON_WRITE
 312             if (SvIsCOW(targ)) {
 313                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 314             } else
 315 #endif
 316             {
 317                 SvPV_free(targ);
 318             }
 319             SvPV_set(targ, SvPVX(dstr));
 320             SvCUR_set(targ, SvCUR(dstr));
 321             SvLEN_set(targ, SvLEN(dstr));
 322             if (DO_UTF8(dstr))
 323                 SvUTF8_on(targ);
 324             SvPV_set(dstr, NULL);
 325
 326             TAINT_IF(cx->sb_rxtainted & 1);
 327             mPUSHi(saviters - 1);
 328
 329             (void)SvPOK_only_UTF8(targ);
 330             TAINT_IF(cx->sb_rxtainted);
 331             SvSETMAGIC(targ);
 332             SvTAINT(targ);
 333
 334             LEAVE_SCOPE(cx->sb_oldsave);
 335             POPSUBST(cx);
 336             RETURNOP(pm->op_next);
 337         }
 338         cx->sb_iters = saviters;
 339     }
 340     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 341         m = s;
 342         s = orig;
 343         cx->sb_orig = orig = RX_SUBBEG(rx);
 344         s = orig + (m - s);
 345         cx->sb_strend = s + (cx->sb_strend - m);
 346     }
 347     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 348     if (m > s) {
 349         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 350             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 351         else
 352             sv_catpvn(dstr, s, m-s);
 353     }
 354     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 355     { /* Update the pos() information. */
 356         SV * const sv = cx->sb_targ;
 357         MAGIC *mg;
 358         SvUPGRADE(sv, SVt_PVMG);
 359         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 360 #ifdef PERL_OLD_COPY_ON_WRITE
 361             if (SvIsCOW(sv))
 362                 sv_force_normal_flags(sv, 0);
 363 #endif
 364             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 365                              NULL, 0);
 366         }
 367         mg->mg_len = m - orig;
 368     }
 369     if (old != rx)
 370         (void)ReREFCNT_inc(rx);
 371     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 372     rxres_save(&cx->sb_rxres, rx);
 373     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 374 }
 375
 376 void
 377 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 378 {
 379     UV *p = (UV*)*rsp;
 380     U32 i;
 381
 382     PERL_ARGS_ASSERT_RXRES_SAVE;
 383     PERL_UNUSED_CONTEXT;
 384
 385     if (!p || p[1] < RX_NPARENS(rx)) {
 386 #ifdef PERL_OLD_COPY_ON_WRITE
 387         i = 7 + RX_NPARENS(rx) * 2;
 388 #else
 389         i = 6 + RX_NPARENS(rx) * 2;
 390 #endif
 391         if (!p)
 392             Newx(p, i, UV);
 393         else
 394             Renew(p, i, UV);
 395         *rsp = (void*)p;
 396     }
 397
 398     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 399     RX_MATCH_COPIED_off(rx);
 400
 401 #ifdef PERL_OLD_COPY_ON_WRITE
 402     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 403     RX_SAVED_COPY(rx) = NULL;
 404 #endif
 405
 406     *p++ = RX_NPARENS(rx);
 407
 408     *p++ = PTR2UV(RX_SUBBEG(rx));
 409     *p++ = (UV)RX_SUBLEN(rx);
 410     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 411         *p++ = (UV)RX_OFFS(rx)[i].start;
 412         *p++ = (UV)RX_OFFS(rx)[i].end;
 413     }
 414 }
 415
 416 static void
 417 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 418 {
 419     UV *p = (UV*)*rsp;
 420     U32 i;
 421
 422     PERL_ARGS_ASSERT_RXRES_RESTORE;
 423     PERL_UNUSED_CONTEXT;
 424
 425     RX_MATCH_COPY_FREE(rx);
 426     RX_MATCH_COPIED_set(rx, *p);
 427     *p++ = 0;
 428
 429 #ifdef PERL_OLD_COPY_ON_WRITE
 430     if (RX_SAVED_COPY(rx))
 431         SvREFCNT_dec (RX_SAVED_COPY(rx));
 432     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 433     *p++ = 0;
 434 #endif
 435
 436     RX_NPARENS(rx) = *p++;
 437
 438     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 439     RX_SUBLEN(rx) = (I32)(*p++);
 440     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 441         RX_OFFS(rx)[i].start = (I32)(*p++);
 442         RX_OFFS(rx)[i].end = (I32)(*p++);
 443     }
 444 }
 445
 446 static void
 447 S_rxres_free(pTHX_ void **rsp)
 448 {
 449     UV * const p = (UV*)*rsp;
 450
 451     PERL_ARGS_ASSERT_RXRES_FREE;
 452     PERL_UNUSED_CONTEXT;
 453
 454     if (p) {
 455 #ifdef PERL_POISON
 456         void *tmp = INT2PTR(char*,*p);
 457         Safefree(tmp);
 458         if (*p)
 459             PoisonFree(*p, 1, sizeof(*p));
 460 #else
 461         Safefree(INT2PTR(char*,*p));
 462 #endif
 463 #ifdef PERL_OLD_COPY_ON_WRITE
 464         if (p[1]) {
 465             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 466         }
 467 #endif
 468         Safefree(p);
 469         *rsp = NULL;
 470     }
 471 }
 472
 473 PP(pp_formline)
 474 {
 475     dVAR; dSP; dMARK; dORIGMARK;
 476     register SV * const tmpForm = *++MARK;
 477     register U32 *fpc;
 478     register char *t;
 479     const char *f;
 480     register I32 arg;
 481     register SV *sv = NULL;
 482     const char *item = NULL;
 483     I32 itemsize  = 0;
 484     I32 fieldsize = 0;
 485     I32 lines = 0;
 486     bool chopspace = (strchr(PL_chopset, ' ') != NULL);
 487     const char *chophere = NULL;
 488     char *linemark = NULL;
 489     NV value;
 490     bool gotsome = FALSE;
 491     STRLEN len;
 492     const STRLEN fudge = SvPOK(tmpForm)
 493                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 494     bool item_is_utf8 = FALSE;
 495     bool targ_is_utf8 = FALSE;
 496     SV * nsv = NULL;
 497     OP * parseres = NULL;
 498     const char *fmt;
 499
 500     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 501         if (SvREADONLY(tmpForm)) {
 502             SvREADONLY_off(tmpForm);
 503             parseres = doparseform(tmpForm);
 504             SvREADONLY_on(tmpForm);
 505         }
 506         else
 507             parseres = doparseform(tmpForm);
 508         if (parseres)
 509             return parseres;
 510     }
 511     SvPV_force(PL_formtarget, len);
 512     if (DO_UTF8(PL_formtarget))
 513         targ_is_utf8 = TRUE;
 514     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 515     t += len;
 516     f = SvPV_const(tmpForm, len);
 517     /* need to jump to the next word */
 518     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 519
 520     for (;;) {
 521         DEBUG_f( {
 522             const char *name = "???";
 523             arg = -1;
 524             switch (*fpc) {
 525             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 526             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 527             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 528             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 529             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 530
 531             case FF_CHECKNL:    name = "CHECKNL";       break;
 532             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 533             case FF_SPACE:      name = "SPACE";         break;
 534             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 535             case FF_ITEM:       name = "ITEM";          break;
 536             case FF_CHOP:       name = "CHOP";          break;
 537             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 538             case FF_NEWLINE:    name = "NEWLINE";       break;
 539             case FF_MORE:       name = "MORE";          break;
 540             case FF_LINEMARK:   name = "LINEMARK";      break;
 541             case FF_END:        name = "END";           break;
 542             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 543             case FF_LINESNGL:   name = "LINESNGL";      break;
 544             }
 545             if (arg >= 0)
 546                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 547             else
 548                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 549         } );
 550         switch (*fpc++) {
 551         case FF_LINEMARK:
 552             linemark = t;
 553             lines++;
 554             gotsome = FALSE;
 555             break;
 556
 557         case FF_LITERAL:
 558             arg = *fpc++;
 559             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 560                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 561                 *t = '\0';
 562                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 563                 t = SvEND(PL_formtarget);
 564                 f += arg;
 565                 break;
 566             }
 567             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 568                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 569                 *t = '\0';
 570                 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
 571                 t = SvEND(PL_formtarget);
 572                 targ_is_utf8 = TRUE;
 573             }
 574             while (arg--)
 575                 *t++ = *f++;
 576             break;
 577
 578         case FF_SKIP:
 579             f += *fpc++;
 580             break;
 581
 582         case FF_FETCH:
 583             arg = *fpc++;
 584             f += arg;
 585             fieldsize = arg;
 586
 587             if (MARK < SP)
 588                 sv = *++MARK;
 589             else {
 590                 sv = &PL_sv_no;
 591                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 592             }
 593             break;
 594
 595         case FF_CHECKNL:
 596             {
 597                 const char *send;
 598                 const char *s = item = SvPV_const(sv, len);
 599                 itemsize = len;
 600                 if (DO_UTF8(sv)) {
 601                     itemsize = sv_len_utf8(sv);
 602                     if (itemsize != (I32)len) {
 603                         I32 itembytes;
 604                         if (itemsize > fieldsize) {
 605                             itemsize = fieldsize;
 606                             itembytes = itemsize;
 607                             sv_pos_u2b(sv, &itembytes, 0);
 608                         }
 609                         else
 610                             itembytes = len;
 611                         send = chophere = s + itembytes;
 612                         while (s < send) {
 613                             if (*s & ~31)
 614                                 gotsome = TRUE;
 615                             else if (*s == '\n')
 616                                 break;
 617                             s++;
 618                         }
 619                         item_is_utf8 = TRUE;
 620                         itemsize = s - item;
 621                         sv_pos_b2u(sv, &itemsize);
 622                         break;
 623                     }
 624                 }
 625                 item_is_utf8 = FALSE;
 626                 if (itemsize > fieldsize)
 627                     itemsize = fieldsize;
 628                 send = chophere = s + itemsize;
 629                 while (s < send) {
 630                     if (*s & ~31)
 631                         gotsome = TRUE;
 632                     else if (*s == '\n')
 633                         break;
 634                     s++;
 635                 }
 636                 itemsize = s - item;
 637                 break;
 638             }
 639
 640         case FF_CHECKCHOP:
 641             {
 642                 const char *s = item = SvPV_const(sv, len);
 643                 itemsize = len;
 644                 if (DO_UTF8(sv)) {
 645                     itemsize = sv_len_utf8(sv);
 646                     if (itemsize != (I32)len) {
 647                         I32 itembytes;
 648                         if (itemsize <= fieldsize) {
 649                             const char *send = chophere = s + itemsize;
 650                             while (s < send) {
 651                                 if (*s == '\r') {
 652                                     itemsize = s - item;
 653                                     chophere = s;
 654                                     break;
 655                                 }
 656                                 if (*s++ & ~31)
 657                                     gotsome = TRUE;
 658                             }
 659                         }
 660                         else {
 661                             const char *send;
 662                             itemsize = fieldsize;
 663                             itembytes = itemsize;
 664                             sv_pos_u2b(sv, &itembytes, 0);
 665                             send = chophere = s + itembytes;
 666                             while (s < send || (s == send && isSPACE(*s))) {
 667                                 if (isSPACE(*s)) {
 668                                     if (chopspace)
 669                                         chophere = s;
 670                                     if (*s == '\r')
 671                                         break;
 672                                 }
 673                                 else {
 674                                     if (*s & ~31)
 675                                         gotsome = TRUE;
 676                                     if (strchr(PL_chopset, *s))
 677                                         chophere = s + 1;
 678                                 }
 679                                 s++;
 680                             }
 681                             itemsize = chophere - item;
 682                             sv_pos_b2u(sv, &itemsize);
 683                         }
 684                         item_is_utf8 = TRUE;
 685                         break;
 686                     }
 687                 }
 688                 item_is_utf8 = FALSE;
 689                 if (itemsize <= fieldsize) {
 690                     const char *const send = chophere = s + itemsize;
 691                     while (s < send) {
 692                         if (*s == '\r') {
 693                             itemsize = s - item;
 694                             chophere = s;
 695                             break;
 696                         }
 697                         if (*s++ & ~31)
 698                             gotsome = TRUE;
 699                     }
 700                 }
 701                 else {
 702                     const char *send;
 703                     itemsize = fieldsize;
 704                     send = chophere = s + itemsize;
 705                     while (s < send || (s == send && isSPACE(*s))) {
 706                         if (isSPACE(*s)) {
 707                             if (chopspace)
 708                                 chophere = s;
 709                             if (*s == '\r')
 710                                 break;
 711                         }
 712                         else {
 713                             if (*s & ~31)
 714                                 gotsome = TRUE;
 715                             if (strchr(PL_chopset, *s))
 716                                 chophere = s + 1;
 717                         }
 718                         s++;
 719                     }
 720                     itemsize = chophere - item;
 721                 }
 722                 break;
 723             }
 724
 725         case FF_SPACE:
 726             arg = fieldsize - itemsize;
 727             if (arg) {
 728                 fieldsize -= arg;
 729                 while (arg-- > 0)
 730                     *t++ = ' ';
 731             }
 732             break;
 733
 734         case FF_HALFSPACE:
 735             arg = fieldsize - itemsize;
 736             if (arg) {
 737                 arg /= 2;
 738                 fieldsize -= arg;
 739                 while (arg-- > 0)
 740                     *t++ = ' ';
 741             }
 742             break;
 743
 744         case FF_ITEM:
 745             {
 746                 const char *s = item;
 747                 arg = itemsize;
 748                 if (item_is_utf8) {
 749                     if (!targ_is_utf8) {
 750                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 751                         *t = '\0';
 752                         sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
 753                                                                     fudge + 1);
 754                         t = SvEND(PL_formtarget);
 755                         targ_is_utf8 = TRUE;
 756                     }
 757                     while (arg--) {
 758                         if (UTF8_IS_CONTINUED(*s)) {
 759                             STRLEN skip = UTF8SKIP(s);
 760                             switch (skip) {
 761                             default:
 762                                 Move(s,t,skip,char);
 763                                 s += skip;
 764                                 t += skip;
 765                                 break;
 766                             case 7: *t++ = *s++;
 767                             case 6: *t++ = *s++;
 768                             case 5: *t++ = *s++;
 769                             case 4: *t++ = *s++;
 770                             case 3: *t++ = *s++;
 771                             case 2: *t++ = *s++;
 772                             case 1: *t++ = *s++;
 773                             }
 774                         }
 775                         else {
 776                             if ( !((*t++ = *s++) & ~31) )
 777                                 t[-1] = ' ';
 778                         }
 779                     }
 780                     break;
 781                 }
 782                 if (targ_is_utf8 && !item_is_utf8) {
 783                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 784                     *t = '\0';
 785                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 786                     for (; t < SvEND(PL_formtarget); t++) {
 787 #ifdef EBCDIC
 788                         const int ch = *t;
 789                         if (iscntrl(ch))
 790 #else
 791                             if (!(*t & ~31))
 792 #endif
 793                                 *t = ' ';
 794                     }
 795                     break;
 796                 }
 797                 while (arg--) {
 798 #ifdef EBCDIC
 799                     const int ch = *t++ = *s++;
 800                     if (iscntrl(ch))
 801 #else
 802                         if ( !((*t++ = *s++) & ~31) )
 803 #endif
 804                             t[-1] = ' ';
 805                 }
 806                 break;
 807             }
 808
 809         case FF_CHOP:
 810             {
 811                 const char *s = chophere;
 812                 if (chopspace) {
 813                     while (isSPACE(*s))
 814                         s++;
 815                 }
 816                 sv_chop(sv,s);
 817                 SvSETMAGIC(sv);
 818                 break;
 819             }
 820
 821         case FF_LINESNGL:
 822             chopspace = 0;
 823         case FF_LINEGLOB:
 824             {
 825                 const bool oneline = fpc[-1] == FF_LINESNGL;
 826                 const char *s = item = SvPV_const(sv, len);
 827                 item_is_utf8 = DO_UTF8(sv);
 828                 itemsize = len;
 829                 if (itemsize) {
 830                     STRLEN to_copy = itemsize;
 831                     const char *const send = s + len;
 832                     const U8 *source = (const U8 *) s;
 833                     U8 *tmp = NULL;
 834
 835                     gotsome = TRUE;
 836                     chophere = s + itemsize;
 837                     while (s < send) {
 838                         if (*s++ == '\n') {
 839                             if (oneline) {
 840                                 to_copy = s - SvPVX_const(sv) - 1;
 841                                 chophere = s;
 842                                 break;
 843                             } else {
 844                                 if (s == send) {
 845                                     itemsize--;
 846                                     to_copy--;
 847                                 } else
 848                                     lines++;
 849                             }
 850                         }
 851                     }
 852                     if (targ_is_utf8 && !item_is_utf8) {
 853                         source = tmp = bytes_to_utf8(source, &to_copy);
 854                         SvCUR_set(PL_formtarget,
 855                                   t - SvPVX_const(PL_formtarget));
 856                     } else {
 857                         if (item_is_utf8 && !targ_is_utf8) {
 858                             /* Upgrade targ to UTF8, and then we reduce it to
 859                                a problem we have a simple solution for.  */
 860                             SvCUR_set(PL_formtarget,
 861                                       t - SvPVX_const(PL_formtarget));
 862                             targ_is_utf8 = TRUE;
 863                             /* Don't need get magic.  */
 864                             sv_utf8_upgrade_nomg(PL_formtarget);
 865                         } else {
 866                             SvCUR_set(PL_formtarget,
 867                                       t - SvPVX_const(PL_formtarget));
 868                         }
 869
 870                         /* Easy. They agree.  */
 871                         assert (item_is_utf8 == targ_is_utf8);
 872                     }
 873                     SvGROW(PL_formtarget,
 874                            SvCUR(PL_formtarget) + to_copy + fudge + 1);
 875                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 876
 877                     Copy(source, t, to_copy, char);
 878                     t += to_copy;
 879                     SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 880                     if (item_is_utf8) {
 881                         if (SvGMAGICAL(sv)) {
 882                             /* Mustn't call sv_pos_b2u() as it does a second
 883                                mg_get(). Is this a bug? Do we need a _flags()
 884                                variant? */
 885                             itemsize = utf8_length(source, source + itemsize);
 886                         } else {
 887                             sv_pos_b2u(sv, &itemsize);
 888                         }
 889                         assert(!tmp);
 890                     } else if (tmp) {
 891                         Safefree(tmp);
 892                     }
 893                 }
 894                 break;
 895             }
 896
 897         case FF_0DECIMAL:
 898             arg = *fpc++;
 899 #if defined(USE_LONG_DOUBLE)
 900             fmt = (const char *)
 901                 ((arg & 256) ?
 902                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 903 #else
 904             fmt = (const char *)
 905                 ((arg & 256) ?
 906                  "%#0*.*f"              : "%0*.*f");
 907 #endif
 908             goto ff_dec;
 909         case FF_DECIMAL:
 910             arg = *fpc++;
 911 #if defined(USE_LONG_DOUBLE)
 912             fmt = (const char *)
 913                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 914 #else
 915             fmt = (const char *)
 916                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 917 #endif
 918         ff_dec:
 919             /* If the field is marked with ^ and the value is undefined,
 920                blank it out. */
 921             if ((arg & 512) && !SvOK(sv)) {
 922                 arg = fieldsize;
 923                 while (arg--)
 924                     *t++ = ' ';
 925                 break;
 926             }
 927             gotsome = TRUE;
 928             value = SvNV(sv);
 929             /* overflow evidence */
 930             if (num_overflow(value, fieldsize, arg)) {
 931                 arg = fieldsize;
 932                 while (arg--)
 933                     *t++ = '#';
 934                 break;
 935             }
 936             /* Formats aren't yet marked for locales, so assume "yes". */
 937             {
 938                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 939                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 940                 RESTORE_NUMERIC_STANDARD();
 941             }
 942             t += fieldsize;
 943             break;
 944
 945         case FF_NEWLINE:
 946             f++;
 947             while (t-- > linemark && *t == ' ') ;
 948             t++;
 949             *t++ = '\n';
 950             break;
 951
 952         case FF_BLANK:
 953             arg = *fpc++;
 954             if (gotsome) {
 955                 if (arg) {              /* repeat until fields exhausted? */
 956                     *t = '\0';
 957                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 958                     lines += FmLINES(PL_formtarget);
 959                     if (targ_is_utf8)
 960                         SvUTF8_on(PL_formtarget);
 961                     FmLINES(PL_formtarget) = lines;
 962                     SP = ORIGMARK;
 963                     RETURNOP(cLISTOP->op_first);
 964                 }
 965             }
 966             else {
 967                 t = linemark;
 968                 lines--;
 969             }
 970             break;
 971
 972         case FF_MORE:
 973             {
 974                 const char *s = chophere;
 975                 const char *send = item + len;
 976                 if (chopspace) {
 977                     while (isSPACE(*s) && (s < send))
 978                         s++;
 979                 }
 980                 if (s < send) {
 981                     char *s1;
 982                     arg = fieldsize - itemsize;
 983                     if (arg) {
 984                         fieldsize -= arg;
 985                         while (arg-- > 0)
 986                             *t++ = ' ';
 987                     }
 988                     s1 = t - 3;
 989                     if (strnEQ(s1,"   ",3)) {
 990                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 991                             s1--;
 992                     }
 993                     *s1++ = '.';
 994                     *s1++ = '.';
 995                     *s1++ = '.';
 996                 }
 997                 break;
 998             }
 999         case FF_END:
1000             *t = '\0';
1001             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1002             if (targ_is_utf8)
1003                 SvUTF8_on(PL_formtarget);
1004             FmLINES(PL_formtarget) += lines;
1005             SP = ORIGMARK;
1006             RETPUSHYES;
1007         }
1008     }
1009 }
1010
1011 PP(pp_grepstart)
1012 {
1013     dVAR; dSP;
1014     SV *src;
1015
1016     if (PL_stack_base + *PL_markstack_ptr == SP) {
1017         (void)POPMARK;
1018         if (GIMME_V == G_SCALAR)
1019             mXPUSHi(0);
1020         RETURNOP(PL_op->op_next->op_next);
1021     }
1022     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1023     pp_pushmark();                              /* push dst */
1024     pp_pushmark();                              /* push src */
1025     ENTER_with_name("grep");                                    /* enter outer scope */
1026
1027     SAVETMPS;
1028     if (PL_op->op_private & OPpGREP_LEX)
1029         SAVESPTR(PAD_SVl(PL_op->op_targ));
1030     else
1031         SAVE_DEFSV;
1032     ENTER_with_name("grep_item");                                       /* enter inner scope */
1033     SAVEVPTR(PL_curpm);
1034
1035     src = PL_stack_base[*PL_markstack_ptr];
1036     SvTEMP_off(src);
1037     if (PL_op->op_private & OPpGREP_LEX)
1038         PAD_SVl(PL_op->op_targ) = src;
1039     else
1040         DEFSV_set(src);
1041
1042     PUTBACK;
1043     if (PL_op->op_type == OP_MAPSTART)
1044         pp_pushmark();                  /* push top */
1045     return ((LOGOP*)PL_op->op_next)->op_other;
1046 }
1047
1048 PP(pp_mapwhile)
1049 {
1050     dVAR; dSP;
1051     const I32 gimme = GIMME_V;
1052     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1053     I32 count;
1054     I32 shift;
1055     SV** src;
1056     SV** dst;
1057
1058     /* first, move source pointer to the next item in the source list */
1059     ++PL_markstack_ptr[-1];
1060
1061     /* if there are new items, push them into the destination list */
1062     if (items && gimme != G_VOID) {
1063         /* might need to make room back there first */
1064         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1065             /* XXX this implementation is very pessimal because the stack
1066              * is repeatedly extended for every set of items.  Is possible
1067              * to do this without any stack extension or copying at all
1068              * by maintaining a separate list over which the map iterates
1069              * (like foreach does). --gsar */
1070
1071             /* everything in the stack after the destination list moves
1072              * towards the end the stack by the amount of room needed */
1073             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1074
1075             /* items to shift up (accounting for the moved source pointer) */
1076             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1077
1078             /* This optimization is by Ben Tilly and it does
1079              * things differently from what Sarathy (gsar)
1080              * is describing.  The downside of this optimization is
1081              * that leaves "holes" (uninitialized and hopefully unused areas)
1082              * to the Perl stack, but on the other hand this
1083              * shouldn't be a problem.  If Sarathy's idea gets
1084              * implemented, this optimization should become
1085              * irrelevant.  --jhi */
1086             if (shift < count)
1087                 shift = count; /* Avoid shifting too often --Ben Tilly */
1088
1089             EXTEND(SP,shift);
1090             src = SP;
1091             dst = (SP += shift);
1092             PL_markstack_ptr[-1] += shift;
1093             *PL_markstack_ptr += shift;
1094             while (count--)
1095                 *dst-- = *src--;
1096         }
1097         /* copy the new items down to the destination list */
1098         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1099         if (gimme == G_ARRAY) {
1100             while (items-- > 0)
1101                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1102         }
1103         else {
1104             /* scalar context: we don't care about which values map returns
1105              * (we use undef here). And so we certainly don't want to do mortal
1106              * copies of meaningless values. */
1107             while (items-- > 0) {
1108                 (void)POPs;
1109                 *dst-- = &PL_sv_undef;
1110             }
1111         }
1112     }
1113     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1114
1115     /* All done yet? */
1116     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1117
1118         (void)POPMARK;                          /* pop top */
1119         LEAVE_with_name("grep");                                        /* exit outer scope */
1120         (void)POPMARK;                          /* pop src */
1121         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1122         (void)POPMARK;                          /* pop dst */
1123         SP = PL_stack_base + POPMARK;           /* pop original mark */
1124         if (gimme == G_SCALAR) {
1125             if (PL_op->op_private & OPpGREP_LEX) {
1126                 SV* sv = sv_newmortal();
1127                 sv_setiv(sv, items);
1128                 PUSHs(sv);
1129             }
1130             else {
1131                 dTARGET;
1132                 XPUSHi(items);
1133             }
1134         }
1135         else if (gimme == G_ARRAY)
1136             SP += items;
1137         RETURN;
1138     }
1139     else {
1140         SV *src;
1141
1142         ENTER_with_name("grep_item");                                   /* enter inner scope */
1143         SAVEVPTR(PL_curpm);
1144
1145         /* set $_ to the new source item */
1146         src = PL_stack_base[PL_markstack_ptr[-1]];
1147         SvTEMP_off(src);
1148         if (PL_op->op_private & OPpGREP_LEX)
1149             PAD_SVl(PL_op->op_targ) = src;
1150         else
1151             DEFSV_set(src);
1152
1153         RETURNOP(cLOGOP->op_other);
1154     }
1155 }
1156
1157 /* Range stuff. */
1158
1159 PP(pp_range)
1160 {
1161     dVAR;
1162     if (GIMME == G_ARRAY)
1163         return NORMAL;
1164     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1165         return cLOGOP->op_other;
1166     else
1167         return NORMAL;
1168 }
1169
1170 PP(pp_flip)
1171 {
1172     dVAR;
1173     dSP;
1174
1175     if (GIMME == G_ARRAY) {
1176         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1177     }
1178     else {
1179         dTOPss;
1180         SV * const targ = PAD_SV(PL_op->op_targ);
1181         int flip = 0;
1182
1183         if (PL_op->op_private & OPpFLIP_LINENUM) {
1184             if (GvIO(PL_last_in_gv)) {
1185                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1186             }
1187             else {
1188                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1189                 if (gv && GvSV(gv))
1190                     flip = SvIV(sv) == SvIV(GvSV(gv));
1191             }
1192         } else {
1193             flip = SvTRUE(sv);
1194         }
1195         if (flip) {
1196             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1197             if (PL_op->op_flags & OPf_SPECIAL) {
1198                 sv_setiv(targ, 1);
1199                 SETs(targ);
1200                 RETURN;
1201             }
1202             else {
1203                 sv_setiv(targ, 0);
1204                 SP--;
1205                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1206             }
1207         }
1208         sv_setpvs(TARG, "");
1209         SETs(targ);
1210         RETURN;
1211     }
1212 }
1213
1214 /* This code tries to decide if "$left .. $right" should use the
1215    magical string increment, or if the range is numeric (we make
1216    an exception for .."0" [#18165]). AMS 20021031. */
1217
1218 #define RANGE_IS_NUMERIC(left,right) ( \
1219         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1220         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1221         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1222           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1223          && (!SvOK(right) || looks_like_number(right))))
1224
1225 PP(pp_flop)
1226 {
1227     dVAR; dSP;
1228
1229     if (GIMME == G_ARRAY) {
1230         dPOPPOPssrl;
1231
1232         SvGETMAGIC(left);
1233         SvGETMAGIC(right);
1234
1235         if (RANGE_IS_NUMERIC(left,right)) {
1236             register IV i, j;
1237             IV max;
1238             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1239                 (SvOK(right) && SvNV(right) > IV_MAX))
1240                 DIE(aTHX_ "Range iterator outside integer range");
1241             i = SvIV(left);
1242             max = SvIV(right);
1243             if (max >= i) {
1244                 j = max - i + 1;
1245                 EXTEND_MORTAL(j);
1246                 EXTEND(SP, j);
1247             }
1248             else
1249                 j = 0;
1250             while (j--) {
1251                 SV * const sv = sv_2mortal(newSViv(i++));
1252                 PUSHs(sv);
1253             }
1254         }
1255         else {
1256             SV * const final = sv_mortalcopy(right);
1257             STRLEN len;
1258             const char * const tmps = SvPV_const(final, len);
1259
1260             SV *sv = sv_mortalcopy(left);
1261             SvPV_force_nolen(sv);
1262             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1263                 XPUSHs(sv);
1264                 if (strEQ(SvPVX_const(sv),tmps))
1265                     break;
1266                 sv = sv_2mortal(newSVsv(sv));
1267                 sv_inc(sv);
1268             }
1269         }
1270     }
1271     else {
1272         dTOPss;
1273         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1274         int flop = 0;
1275         sv_inc(targ);
1276
1277         if (PL_op->op_private & OPpFLIP_LINENUM) {
1278             if (GvIO(PL_last_in_gv)) {
1279                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1280             }
1281             else {
1282                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1283                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1284             }
1285         }
1286         else {
1287             flop = SvTRUE(sv);
1288         }
1289
1290         if (flop) {
1291             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1292             sv_catpvs(targ, "E0");
1293         }
1294         SETs(targ);
1295     }
1296
1297     RETURN;
1298 }
1299
1300 /* Control. */
1301
1302 static const char * const context_name[] = {
1303     "pseudo-block",
1304     NULL, /* CXt_WHEN never actually needs "block" */
1305     NULL, /* CXt_BLOCK never actually needs "block" */
1306     NULL, /* CXt_GIVEN never actually needs "block" */
1307     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1308     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1309     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1310     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1311     "subroutine",
1312     "format",
1313     "eval",
1314     "substitution",
1315 };
1316
1317 STATIC I32
1318 S_dopoptolabel(pTHX_ const char *label)
1319 {
1320     dVAR;
1321     register I32 i;
1322
1323     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1324
1325     for (i = cxstack_ix; i >= 0; i--) {
1326         register const PERL_CONTEXT * const cx = &cxstack[i];
1327         switch (CxTYPE(cx)) {
1328         case CXt_SUBST:
1329         case CXt_SUB:
1330         case CXt_FORMAT:
1331         case CXt_EVAL:
1332         case CXt_NULL:
1333             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335             if (CxTYPE(cx) == CXt_NULL)
1336                 return -1;
1337             break;
1338         case CXt_LOOP_LAZYIV:
1339         case CXt_LOOP_LAZYSV:
1340         case CXt_LOOP_FOR:
1341         case CXt_LOOP_PLAIN:
1342           {
1343             const char *cx_label = CxLABEL(cx);
1344             if (!cx_label || strNE(label, cx_label) ) {
1345                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1346                         (long)i, cx_label));
1347                 continue;
1348             }
1349             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1350             return i;
1351           }
1352         }
1353     }
1354     return i;
1355 }
1356
1357
1358
1359 I32
1360 Perl_dowantarray(pTHX)
1361 {
1362     dVAR;
1363     const I32 gimme = block_gimme();
1364     return (gimme == G_VOID) ? G_SCALAR : gimme;
1365 }
1366
1367 I32
1368 Perl_block_gimme(pTHX)
1369 {
1370     dVAR;
1371     const I32 cxix = dopoptosub(cxstack_ix);
1372     if (cxix < 0)
1373         return G_VOID;
1374
1375     switch (cxstack[cxix].blk_gimme) {
1376     case G_VOID:
1377         return G_VOID;
1378     case G_SCALAR:
1379         return G_SCALAR;
1380     case G_ARRAY:
1381         return G_ARRAY;
1382     default:
1383         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1384         /* NOTREACHED */
1385         return 0;
1386     }
1387 }
1388
1389 I32
1390 Perl_is_lvalue_sub(pTHX)
1391 {
1392     dVAR;
1393     const I32 cxix = dopoptosub(cxstack_ix);
1394     assert(cxix >= 0);  /* We should only be called from inside subs */
1395
1396     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1397         return CxLVAL(cxstack + cxix);
1398     else
1399         return 0;
1400 }
1401
1402 STATIC I32
1403 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1404 {
1405     dVAR;
1406     I32 i;
1407
1408     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1409
1410     for (i = startingblock; i >= 0; i--) {
1411         register const PERL_CONTEXT * const cx = &cxstk[i];
1412         switch (CxTYPE(cx)) {
1413         default:
1414             continue;
1415         case CXt_EVAL:
1416         case CXt_SUB:
1417         case CXt_FORMAT:
1418             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1419             return i;
1420         }
1421     }
1422     return i;
1423 }
1424
1425 STATIC I32
1426 S_dopoptoeval(pTHX_ I32 startingblock)
1427 {
1428     dVAR;
1429     I32 i;
1430     for (i = startingblock; i >= 0; i--) {
1431         register const PERL_CONTEXT *cx = &cxstack[i];
1432         switch (CxTYPE(cx)) {
1433         default:
1434             continue;
1435         case CXt_EVAL:
1436             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1437             return i;
1438         }
1439     }
1440     return i;
1441 }
1442
1443 STATIC I32
1444 S_dopoptoloop(pTHX_ I32 startingblock)
1445 {
1446     dVAR;
1447     I32 i;
1448     for (i = startingblock; i >= 0; i--) {
1449         register const PERL_CONTEXT * const cx = &cxstack[i];
1450         switch (CxTYPE(cx)) {
1451         case CXt_SUBST:
1452         case CXt_SUB:
1453         case CXt_FORMAT:
1454         case CXt_EVAL:
1455         case CXt_NULL:
1456             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1457                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1458             if ((CxTYPE(cx)) == CXt_NULL)
1459                 return -1;
1460             break;
1461         case CXt_LOOP_LAZYIV:
1462         case CXt_LOOP_LAZYSV:
1463         case CXt_LOOP_FOR:
1464         case CXt_LOOP_PLAIN:
1465             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1466             return i;
1467         }
1468     }
1469     return i;
1470 }
1471
1472 STATIC I32
1473 S_dopoptogiven(pTHX_ I32 startingblock)
1474 {
1475     dVAR;
1476     I32 i;
1477     for (i = startingblock; i >= 0; i--) {
1478         register const PERL_CONTEXT *cx = &cxstack[i];
1479         switch (CxTYPE(cx)) {
1480         default:
1481             continue;
1482         case CXt_GIVEN:
1483             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1484             return i;
1485         case CXt_LOOP_PLAIN:
1486             assert(!CxFOREACHDEF(cx));
1487             break;
1488         case CXt_LOOP_LAZYIV:
1489         case CXt_LOOP_LAZYSV:
1490         case CXt_LOOP_FOR:
1491             if (CxFOREACHDEF(cx)) {
1492                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1493                 return i;
1494             }
1495         }
1496     }
1497     return i;
1498 }
1499
1500 STATIC I32
1501 S_dopoptowhen(pTHX_ I32 startingblock)
1502 {
1503     dVAR;
1504     I32 i;
1505     for (i = startingblock; i >= 0; i--) {
1506         register const PERL_CONTEXT *cx = &cxstack[i];
1507         switch (CxTYPE(cx)) {
1508         default:
1509             continue;
1510         case CXt_WHEN:
1511             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1512             return i;
1513         }
1514     }
1515     return i;
1516 }
1517
1518 void
1519 Perl_dounwind(pTHX_ I32 cxix)
1520 {
1521     dVAR;
1522     I32 optype;
1523
1524     while (cxstack_ix > cxix) {
1525         SV *sv;
1526         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1527         DEBUG_CX("UNWIND");                                             \
1528         /* Note: we don't need to restore the base context info till the end. */
1529         switch (CxTYPE(cx)) {
1530         case CXt_SUBST:
1531             POPSUBST(cx);
1532             continue;  /* not break */
1533         case CXt_SUB:
1534             POPSUB(cx,sv);
1535             LEAVESUB(sv);
1536             break;
1537         case CXt_EVAL:
1538             POPEVAL(cx);
1539             break;
1540         case CXt_LOOP_LAZYIV:
1541         case CXt_LOOP_LAZYSV:
1542         case CXt_LOOP_FOR:
1543         case CXt_LOOP_PLAIN:
1544             POPLOOP(cx);
1545             break;
1546         case CXt_NULL:
1547             break;
1548         case CXt_FORMAT:
1549             POPFORMAT(cx);
1550             break;
1551         }
1552         cxstack_ix--;
1553     }
1554     PERL_UNUSED_VAR(optype);
1555 }
1556
1557 void
1558 Perl_qerror(pTHX_ SV *err)
1559 {
1560     dVAR;
1561
1562     PERL_ARGS_ASSERT_QERROR;
1563
1564     if (PL_in_eval)
1565         sv_catsv(ERRSV, err);
1566     else if (PL_errors)
1567         sv_catsv(PL_errors, err);
1568     else
1569         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1570     if (PL_parser)
1571         ++PL_parser->error_count;
1572 }
1573
1574 void
1575 Perl_die_where(pTHX_ SV *msv)
1576 {
1577     dVAR;
1578
1579     if (PL_in_eval) {
1580         I32 cxix;
1581         I32 gimme;
1582
1583         if (msv) {
1584             if (PL_in_eval & EVAL_KEEPERR) {
1585                 static const char prefix[] = "\t(in cleanup) ";
1586                 SV * const err = ERRSV;
1587                 const char *e = NULL;
1588                 if (!SvPOK(err))
1589                     sv_setpvs(err,"");
1590                 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
1591                     STRLEN len;
1592                     STRLEN msglen;
1593                     const char* message = SvPV_const(msv, msglen);
1594                     e = SvPV_const(err, len);
1595                     e += len - msglen;
1596                     if (*e != *message || strNE(e,message))
1597                         e = NULL;
1598                 }
1599                 if (!e) {
1600                     STRLEN start;
1601                     SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
1602                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1603                     sv_catsv(err, msv);
1604                     start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
1605                     Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1606                                    SvPVX_const(err)+start);
1607                 }
1608             }
1609             else {
1610                 STRLEN msglen;
1611                 const char* message = SvPV_const(msv, msglen);
1612                 sv_setpvn(ERRSV, message, msglen);
1613                 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
1614             }
1615         }
1616
1617         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1618                && PL_curstackinfo->si_prev)
1619         {
1620             dounwind(-1);
1621             POPSTACK;
1622         }
1623
1624         if (cxix >= 0) {
1625             I32 optype;
1626             SV *namesv;
1627             register PERL_CONTEXT *cx;
1628             SV **newsp;
1629
1630             if (cxix < cxstack_ix)
1631                 dounwind(cxix);
1632
1633             POPBLOCK(cx,PL_curpm);
1634             if (CxTYPE(cx) != CXt_EVAL) {
1635                 STRLEN msglen;
1636                 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1637                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1638                 PerlIO_write(Perl_error_log, message, msglen);
1639                 my_exit(1);
1640             }
1641             POPEVAL(cx);
1642             namesv = cx->blk_eval.old_namesv;
1643
1644             if (gimme == G_SCALAR)
1645                 *++newsp = &PL_sv_undef;
1646             PL_stack_sp = newsp;
1647
1648             LEAVE;
1649
1650             /* LEAVE could clobber PL_curcop (see save_re_context())
1651              * XXX it might be better to find a way to avoid messing with
1652              * PL_curcop in save_re_context() instead, but this is a more
1653              * minimal fix --GSAR */
1654             PL_curcop = cx->blk_oldcop;
1655
1656             if (optype == OP_REQUIRE) {
1657                 const char* const msg = SvPVx_nolen_const(ERRSV);
1658                 (void)hv_store(GvHVn(PL_incgv),
1659                                SvPVX_const(namesv), SvCUR(namesv),
1660                                &PL_sv_undef, 0);
1661                 /* note that unlike pp_entereval, pp_require isn't
1662                  * supposed to trap errors. So now that we've popped the
1663                  * EVAL that pp_require pushed, and processed the error
1664                  * message, rethrow the error */
1665                 DIE(aTHX_ "%sCompilation failed in require",
1666                     *msg ? msg : "Unknown error\n");
1667             }
1668             assert(CxTYPE(cx) == CXt_EVAL);
1669             PL_restartjmpenv = cx->blk_eval.cur_top_env;
1670             PL_restartop = cx->blk_eval.retop;
1671             JMPENV_JUMP(3);
1672             /* NOTREACHED */
1673         }
1674     }
1675
1676     write_to_stderr( msv ? msv : ERRSV );
1677     my_failure_exit();
1678     /* NOTREACHED */
1679 }
1680
1681 PP(pp_xor)
1682 {
1683     dVAR; dSP; dPOPTOPssrl;
1684     if (SvTRUE(left) != SvTRUE(right))
1685         RETSETYES;
1686     else
1687         RETSETNO;
1688 }
1689
1690 PP(pp_caller)
1691 {
1692     dVAR;
1693     dSP;
1694     register I32 cxix = dopoptosub(cxstack_ix);
1695     register const PERL_CONTEXT *cx;
1696     register const PERL_CONTEXT *ccstack = cxstack;
1697     const PERL_SI *top_si = PL_curstackinfo;
1698     I32 gimme;
1699     const char *stashname;
1700     I32 count = 0;
1701
1702     if (MAXARG)
1703         count = POPi;
1704
1705     for (;;) {
1706         /* we may be in a higher stacklevel, so dig down deeper */
1707         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1708             top_si = top_si->si_prev;
1709             ccstack = top_si->si_cxstack;
1710             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1711         }
1712         if (cxix < 0) {
1713             if (GIMME != G_ARRAY) {
1714                 EXTEND(SP, 1);
1715                 RETPUSHUNDEF;
1716             }
1717             RETURN;
1718         }
1719         /* caller() should not report the automatic calls to &DB::sub */
1720         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1721                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1722             count++;
1723         if (!count--)
1724             break;
1725         cxix = dopoptosub_at(ccstack, cxix - 1);
1726     }
1727
1728     cx = &ccstack[cxix];
1729     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1730         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1731         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1732            field below is defined for any cx. */
1733         /* caller() should not report the automatic calls to &DB::sub */
1734         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1735             cx = &ccstack[dbcxix];
1736     }
1737
1738     stashname = CopSTASHPV(cx->blk_oldcop);
1739     if (GIMME != G_ARRAY) {
1740         EXTEND(SP, 1);
1741         if (!stashname)
1742             PUSHs(&PL_sv_undef);
1743         else {
1744             dTARGET;
1745             sv_setpv(TARG, stashname);
1746             PUSHs(TARG);
1747         }
1748         RETURN;
1749     }
1750
1751     EXTEND(SP, 11);
1752
1753     if (!stashname)
1754         PUSHs(&PL_sv_undef);
1755     else
1756         mPUSHs(newSVpv(stashname, 0));
1757     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1758     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1759     if (!MAXARG)
1760         RETURN;
1761     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1762         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1763         /* So is ccstack[dbcxix]. */
1764         if (isGV(cvgv)) {
1765             SV * const sv = newSV(0);
1766             gv_efullname3(sv, cvgv, NULL);
1767             mPUSHs(sv);
1768             PUSHs(boolSV(CxHASARGS(cx)));
1769         }
1770         else {
1771             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1772             PUSHs(boolSV(CxHASARGS(cx)));
1773         }
1774     }
1775     else {
1776         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1777         mPUSHi(0);
1778     }
1779     gimme = (I32)cx->blk_gimme;
1780     if (gimme == G_VOID)
1781         PUSHs(&PL_sv_undef);
1782     else
1783         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1784     if (CxTYPE(cx) == CXt_EVAL) {
1785         /* eval STRING */
1786         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1787             PUSHs(cx->blk_eval.cur_text);
1788             PUSHs(&PL_sv_no);
1789         }
1790         /* require */
1791         else if (cx->blk_eval.old_namesv) {
1792             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1793             PUSHs(&PL_sv_yes);
1794         }
1795         /* eval BLOCK (try blocks have old_namesv == 0) */
1796         else {
1797             PUSHs(&PL_sv_undef);
1798             PUSHs(&PL_sv_undef);
1799         }
1800     }
1801     else {
1802         PUSHs(&PL_sv_undef);
1803         PUSHs(&PL_sv_undef);
1804     }
1805     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1806         && CopSTASH_eq(PL_curcop, PL_debstash))
1807     {
1808         AV * const ary = cx->blk_sub.argarray;
1809         const int off = AvARRAY(ary) - AvALLOC(ary);
1810
1811         if (!PL_dbargs) {
1812             PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1813                                                   SVt_PVAV)));
1814             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1815         }
1816
1817         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1818             av_extend(PL_dbargs, AvFILLp(ary) + off);
1819         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1820         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1821     }
1822     /* XXX only hints propagated via op_private are currently
1823      * visible (others are not easily accessible, since they
1824      * use the global PL_hints) */
1825     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1826     {
1827         SV * mask ;
1828         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1829
1830         if  (old_warnings == pWARN_NONE ||
1831                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1832             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1833         else if (old_warnings == pWARN_ALL ||
1834                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1835             /* Get the bit mask for $warnings::Bits{all}, because
1836              * it could have been extended by warnings::register */
1837             SV **bits_all;
1838             HV * const bits = get_hv("warnings::Bits", 0);
1839             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1840                 mask = newSVsv(*bits_all);
1841             }
1842             else {
1843                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1844             }
1845         }
1846         else
1847             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1848         mPUSHs(mask);
1849     }
1850
1851     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1852           sv_2mortal(newRV_noinc(
1853                                  MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1854                                               cx->blk_oldcop->cop_hints_hash))))
1855           : &PL_sv_undef);
1856     RETURN;
1857 }
1858
1859 PP(pp_reset)
1860 {
1861     dVAR;
1862     dSP;
1863     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1864     sv_reset(tmps, CopSTASH(PL_curcop));
1865     PUSHs(&PL_sv_yes);
1866     RETURN;
1867 }
1868
1869 /* like pp_nextstate, but used instead when the debugger is active */
1870
1871 PP(pp_dbstate)
1872 {
1873     dVAR;
1874     PL_curcop = (COP*)PL_op;
1875     TAINT_NOT;          /* Each statement is presumed innocent */
1876     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1877     FREETMPS;
1878
1879     PERL_ASYNC_CHECK();
1880
1881     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1882             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1883     {
1884         dSP;
1885         register PERL_CONTEXT *cx;
1886         const I32 gimme = G_ARRAY;
1887         U8 hasargs;
1888         GV * const gv = PL_DBgv;
1889         register CV * const cv = GvCV(gv);
1890
1891         if (!cv)
1892             DIE(aTHX_ "No DB::DB routine defined");
1893
1894         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1895             /* don't do recursive DB::DB call */
1896             return NORMAL;
1897
1898         ENTER;
1899         SAVETMPS;
1900
1901         SAVEI32(PL_debug);
1902         SAVESTACK_POS();
1903         PL_debug = 0;
1904         hasargs = 0;
1905         SPAGAIN;
1906
1907         if (CvISXSUB(cv)) {
1908             CvDEPTH(cv)++;
1909             PUSHMARK(SP);
1910             (void)(*CvXSUB(cv))(aTHX_ cv);
1911             CvDEPTH(cv)--;
1912             FREETMPS;
1913             LEAVE;
1914             return NORMAL;
1915         }
1916         else {
1917             PUSHBLOCK(cx, CXt_SUB, SP);
1918             PUSHSUB_DB(cx);
1919             cx->blk_sub.retop = PL_op->op_next;
1920             CvDEPTH(cv)++;
1921             SAVECOMPPAD();
1922             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1923             RETURNOP(CvSTART(cv));
1924         }
1925     }
1926     else
1927         return NORMAL;
1928 }
1929
1930 PP(pp_enteriter)
1931 {
1932     dVAR; dSP; dMARK;
1933     register PERL_CONTEXT *cx;
1934     const I32 gimme = GIMME_V;
1935     SV **svp;
1936     U8 cxtype = CXt_LOOP_FOR;
1937 #ifdef USE_ITHREADS
1938     PAD *iterdata;
1939 #endif
1940
1941     ENTER_with_name("loop1");
1942     SAVETMPS;
1943
1944     if (PL_op->op_targ) {
1945         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1946             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1947             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1948                     SVs_PADSTALE, SVs_PADSTALE);
1949         }
1950         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1951 #ifndef USE_ITHREADS
1952         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1953 #else
1954         iterdata = NULL;
1955 #endif
1956     }
1957     else {
1958         GV * const gv = MUTABLE_GV(POPs);
1959         svp = &GvSV(gv);                        /* symbol table variable */
1960         SAVEGENERICSV(*svp);
1961         *svp = newSV(0);
1962 #ifdef USE_ITHREADS
1963         iterdata = (PAD*)gv;
1964 #endif
1965     }
1966
1967     if (PL_op->op_private & OPpITER_DEF)
1968         cxtype |= CXp_FOR_DEF;
1969
1970     ENTER_with_name("loop2");
1971
1972     PUSHBLOCK(cx, cxtype, SP);
1973 #ifdef USE_ITHREADS
1974     PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1975 #else
1976     PUSHLOOP_FOR(cx, svp, MARK, 0);
1977 #endif
1978     if (PL_op->op_flags & OPf_STACKED) {
1979         SV *maybe_ary = POPs;
1980         if (SvTYPE(maybe_ary) != SVt_PVAV) {
1981             dPOPss;
1982             SV * const right = maybe_ary;
1983             SvGETMAGIC(sv);
1984             SvGETMAGIC(right);
1985             if (RANGE_IS_NUMERIC(sv,right)) {
1986                 cx->cx_type &= ~CXTYPEMASK;
1987                 cx->cx_type |= CXt_LOOP_LAZYIV;
1988                 /* Make sure that no-one re-orders cop.h and breaks our
1989                    assumptions */
1990                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1991 #ifdef NV_PRESERVES_UV
1992                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1993                                   (SvNV(sv) > (NV)IV_MAX)))
1994                         ||
1995                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1996                                      (SvNV(right) < (NV)IV_MIN))))
1997 #else
1998                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1999                                   ||
2000                                   ((SvNV(sv) > 0) &&
2001                                         ((SvUV(sv) > (UV)IV_MAX) ||
2002                                          (SvNV(sv) > (NV)UV_MAX)))))
2003                         ||
2004                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2005                                      ||
2006                                      ((SvNV(right) > 0) &&
2007                                         ((SvUV(right) > (UV)IV_MAX) ||
2008                                          (SvNV(right) > (NV)UV_MAX))))))
2009 #endif
2010                     DIE(aTHX_ "Range iterator outside integer range");
2011                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2012                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2013 #ifdef DEBUGGING
2014                 /* for correct -Dstv display */
2015                 cx->blk_oldsp = sp - PL_stack_base;
2016 #endif
2017             }
2018             else {
2019                 cx->cx_type &= ~CXTYPEMASK;
2020                 cx->cx_type |= CXt_LOOP_LAZYSV;
2021                 /* Make sure that no-one re-orders cop.h and breaks our
2022                    assumptions */
2023                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2024                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2025                 cx->blk_loop.state_u.lazysv.end = right;
2026                 SvREFCNT_inc(right);
2027                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2028                 /* This will do the upgrade to SVt_PV, and warn if the value
2029                    is uninitialised.  */
2030                 (void) SvPV_nolen_const(right);
2031                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2032                    to replace !SvOK() with a pointer to "".  */
2033                 if (!SvOK(right)) {
2034                     SvREFCNT_dec(right);
2035                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2036                 }
2037             }
2038         }
2039         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2040             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2041             SvREFCNT_inc(maybe_ary);
2042             cx->blk_loop.state_u.ary.ix =
2043                 (PL_op->op_private & OPpITER_REVERSED) ?
2044                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2045                 -1;
2046         }
2047     }
2048     else { /* iterating over items on the stack */
2049         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2050         if (PL_op->op_private & OPpITER_REVERSED) {
2051             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2052         }
2053         else {
2054             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2055         }
2056     }
2057
2058     RETURN;
2059 }
2060
2061 PP(pp_enterloop)
2062 {
2063     dVAR; dSP;
2064     register PERL_CONTEXT *cx;
2065     const I32 gimme = GIMME_V;
2066
2067     ENTER_with_name("loop1");
2068     SAVETMPS;
2069     ENTER_with_name("loop2");
2070
2071     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2072     PUSHLOOP_PLAIN(cx, SP);
2073
2074     RETURN;
2075 }
2076
2077 PP(pp_leaveloop)
2078 {
2079     dVAR; dSP;
2080     register PERL_CONTEXT *cx;
2081     I32 gimme;
2082     SV **newsp;
2083     PMOP *newpm;
2084     SV **mark;
2085
2086     POPBLOCK(cx,newpm);
2087     assert(CxTYPE_is_LOOP(cx));
2088     mark = newsp;
2089     newsp = PL_stack_base + cx->blk_loop.resetsp;
2090
2091     TAINT_NOT;
2092     if (gimme == G_VOID)
2093         NOOP;
2094     else if (gimme == G_SCALAR) {
2095         if (mark < SP)
2096             *++newsp = sv_mortalcopy(*SP);
2097         else
2098             *++newsp = &PL_sv_undef;
2099     }
2100     else {
2101         while (mark < SP) {
2102             *++newsp = sv_mortalcopy(*++mark);
2103             TAINT_NOT;          /* Each item is independent */
2104         }
2105     }
2106     SP = newsp;
2107     PUTBACK;
2108
2109     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2110     PL_curpm = newpm;   /* ... and pop $1 et al */
2111
2112     LEAVE_with_name("loop2");
2113     LEAVE_with_name("loop1");
2114
2115     return NORMAL;
2116 }
2117
2118 PP(pp_return)
2119 {
2120     dVAR; dSP; dMARK;
2121     register PERL_CONTEXT *cx;
2122     bool popsub2 = FALSE;
2123     bool clear_errsv = FALSE;
2124     I32 gimme;
2125     SV **newsp;
2126     PMOP *newpm;
2127     I32 optype = 0;
2128     SV *namesv;
2129     SV *sv;
2130     OP *retop = NULL;
2131
2132     const I32 cxix = dopoptosub(cxstack_ix);
2133
2134     if (cxix < 0) {
2135         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2136                                      * sort block, which is a CXt_NULL
2137                                      * not a CXt_SUB */
2138             dounwind(0);
2139             PL_stack_base[1] = *PL_stack_sp;
2140             PL_stack_sp = PL_stack_base + 1;
2141             return 0;
2142         }
2143         else
2144             DIE(aTHX_ "Can't return outside a subroutine");
2145     }
2146     if (cxix < cxstack_ix)
2147         dounwind(cxix);
2148
2149     if (CxMULTICALL(&cxstack[cxix])) {
2150         gimme = cxstack[cxix].blk_gimme;
2151         if (gimme == G_VOID)
2152             PL_stack_sp = PL_stack_base;
2153         else if (gimme == G_SCALAR) {
2154             PL_stack_base[1] = *PL_stack_sp;
2155             PL_stack_sp = PL_stack_base + 1;
2156         }
2157         return 0;
2158     }
2159
2160     POPBLOCK(cx,newpm);
2161     switch (CxTYPE(cx)) {
2162     case CXt_SUB:
2163         popsub2 = TRUE;
2164         retop = cx->blk_sub.retop;
2165         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2166         break;
2167     case CXt_EVAL:
2168         if (!(PL_in_eval & EVAL_KEEPERR))
2169             clear_errsv = TRUE;
2170         POPEVAL(cx);
2171         namesv = cx->blk_eval.old_namesv;
2172         retop = cx->blk_eval.retop;
2173         if (CxTRYBLOCK(cx))
2174             break;
2175         lex_end();
2176         if (optype == OP_REQUIRE &&
2177             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2178         {
2179             /* Unassume the success we assumed earlier. */
2180             (void)hv_delete(GvHVn(PL_incgv),
2181                             SvPVX_const(namesv), SvCUR(namesv),
2182                             G_DISCARD);
2183             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2184         }
2185         break;
2186     case CXt_FORMAT:
2187         POPFORMAT(cx);
2188         retop = cx->blk_sub.retop;
2189         break;
2190     default:
2191         DIE(aTHX_ "panic: return");
2192     }
2193
2194     TAINT_NOT;
2195     if (gimme == G_SCALAR) {
2196         if (MARK < SP) {
2197             if (popsub2) {
2198                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2199                     if (SvTEMP(TOPs)) {
2200                         *++newsp = SvREFCNT_inc(*SP);
2201                         FREETMPS;
2202                         sv_2mortal(*newsp);
2203                     }
2204                     else {
2205                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2206                         FREETMPS;
2207                         *++newsp = sv_mortalcopy(sv);
2208                         SvREFCNT_dec(sv);
2209                     }
2210                 }
2211                 else
2212                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2213             }
2214             else
2215                 *++newsp = sv_mortalcopy(*SP);
2216         }
2217         else
2218             *++newsp = &PL_sv_undef;
2219     }
2220     else if (gimme == G_ARRAY) {
2221         while (++MARK <= SP) {
2222             *++newsp = (popsub2 && SvTEMP(*MARK))
2223                         ? *MARK : sv_mortalcopy(*MARK);
2224             TAINT_NOT;          /* Each item is independent */
2225         }
2226     }
2227     PL_stack_sp = newsp;
2228
2229     LEAVE;
2230     /* Stack values are safe: */
2231     if (popsub2) {
2232         cxstack_ix--;
2233         POPSUB(cx,sv);  /* release CV and @_ ... */
2234     }
2235     else
2236         sv = NULL;
2237     PL_curpm = newpm;   /* ... and pop $1 et al */
2238
2239     LEAVESUB(sv);
2240     if (clear_errsv) {
2241         CLEAR_ERRSV();
2242     }
2243     return retop;
2244 }
2245
2246 PP(pp_last)
2247 {
2248     dVAR; dSP;
2249     I32 cxix;
2250     register PERL_CONTEXT *cx;
2251     I32 pop2 = 0;
2252     I32 gimme;
2253     I32 optype;
2254     OP *nextop = NULL;
2255     SV **newsp;
2256     PMOP *newpm;
2257     SV **mark;
2258     SV *sv = NULL;
2259
2260
2261     if (PL_op->op_flags & OPf_SPECIAL) {
2262         cxix = dopoptoloop(cxstack_ix);
2263         if (cxix < 0)
2264             DIE(aTHX_ "Can't \"last\" outside a loop block");
2265     }
2266     else {
2267         cxix = dopoptolabel(cPVOP->op_pv);
2268         if (cxix < 0)
2269             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2270     }
2271     if (cxix < cxstack_ix)
2272         dounwind(cxix);
2273
2274     POPBLOCK(cx,newpm);
2275     cxstack_ix++; /* temporarily protect top context */
2276     mark = newsp;
2277     switch (CxTYPE(cx)) {
2278     case CXt_LOOP_LAZYIV:
2279     case CXt_LOOP_LAZYSV:
2280     case CXt_LOOP_FOR:
2281     case CXt_LOOP_PLAIN:
2282         pop2 = CxTYPE(cx);
2283         newsp = PL_stack_base + cx->blk_loop.resetsp;
2284         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2285         break;
2286     case CXt_SUB:
2287         pop2 = CXt_SUB;
2288         nextop = cx->blk_sub.retop;
2289         break;
2290     case CXt_EVAL:
2291         POPEVAL(cx);
2292         nextop = cx->blk_eval.retop;
2293         break;
2294     case CXt_FORMAT:
2295         POPFORMAT(cx);
2296         nextop = cx->blk_sub.retop;
2297         break;
2298     default:
2299         DIE(aTHX_ "panic: last");
2300     }
2301
2302     TAINT_NOT;
2303     if (gimme == G_SCALAR) {
2304         if (MARK < SP)
2305             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2306                         ? *SP : sv_mortalcopy(*SP);
2307         else
2308             *++newsp = &PL_sv_undef;
2309     }
2310     else if (gimme == G_ARRAY) {
2311         while (++MARK <= SP) {
2312             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2313                         ? *MARK : sv_mortalcopy(*MARK);
2314             TAINT_NOT;          /* Each item is independent */
2315         }
2316     }
2317     SP = newsp;
2318     PUTBACK;
2319
2320     LEAVE;
2321     cxstack_ix--;
2322     /* Stack values are safe: */
2323     switch (pop2) {
2324     case CXt_LOOP_LAZYIV:
2325     case CXt_LOOP_PLAIN:
2326     case CXt_LOOP_LAZYSV:
2327     case CXt_LOOP_FOR:
2328         POPLOOP(cx);    /* release loop vars ... */
2329         LEAVE;
2330         break;
2331     case CXt_SUB:
2332         POPSUB(cx,sv);  /* release CV and @_ ... */
2333         break;
2334     }
2335     PL_curpm = newpm;   /* ... and pop $1 et al */
2336
2337     LEAVESUB(sv);
2338     PERL_UNUSED_VAR(optype);
2339     PERL_UNUSED_VAR(gimme);
2340     return nextop;
2341 }
2342
2343 PP(pp_next)
2344 {
2345     dVAR;
2346     I32 cxix;
2347     register PERL_CONTEXT *cx;
2348     I32 inner;
2349
2350     if (PL_op->op_flags & OPf_SPECIAL) {
2351         cxix = dopoptoloop(cxstack_ix);
2352         if (cxix < 0)
2353             DIE(aTHX_ "Can't \"next\" outside a loop block");
2354     }
2355     else {
2356         cxix = dopoptolabel(cPVOP->op_pv);
2357         if (cxix < 0)
2358             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2359     }
2360     if (cxix < cxstack_ix)
2361         dounwind(cxix);
2362
2363     /* clear off anything above the scope we're re-entering, but
2364      * save the rest until after a possible continue block */
2365     inner = PL_scopestack_ix;
2366     TOPBLOCK(cx);
2367     if (PL_scopestack_ix < inner)
2368         leave_scope(PL_scopestack[PL_scopestack_ix]);
2369     PL_curcop = cx->blk_oldcop;
2370     return CX_LOOP_NEXTOP_GET(cx);
2371 }
2372
2373 PP(pp_redo)
2374 {
2375     dVAR;
2376     I32 cxix;
2377     register PERL_CONTEXT *cx;
2378     I32 oldsave;
2379     OP* redo_op;
2380
2381     if (PL_op->op_flags & OPf_SPECIAL) {
2382         cxix = dopoptoloop(cxstack_ix);
2383         if (cxix < 0)
2384             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2385     }
2386     else {
2387         cxix = dopoptolabel(cPVOP->op_pv);
2388         if (cxix < 0)
2389             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2390     }
2391     if (cxix < cxstack_ix)
2392         dounwind(cxix);
2393
2394     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2395     if (redo_op->op_type == OP_ENTER) {
2396         /* pop one less context to avoid $x being freed in while (my $x..) */
2397         cxstack_ix++;
2398         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2399         redo_op = redo_op->op_next;
2400     }
2401
2402     TOPBLOCK(cx);
2403     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2404     LEAVE_SCOPE(oldsave);
2405     FREETMPS;
2406     PL_curcop = cx->blk_oldcop;
2407     return redo_op;
2408 }
2409
2410 STATIC OP *
2411 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2412 {
2413     dVAR;
2414     OP **ops = opstack;
2415     static const char too_deep[] = "Target of goto is too deeply nested";
2416
2417     PERL_ARGS_ASSERT_DOFINDLABEL;
2418
2419     if (ops >= oplimit)
2420         Perl_croak(aTHX_ too_deep);
2421     if (o->op_type == OP_LEAVE ||
2422         o->op_type == OP_SCOPE ||
2423         o->op_type == OP_LEAVELOOP ||
2424         o->op_type == OP_LEAVESUB ||
2425         o->op_type == OP_LEAVETRY)
2426     {
2427         *ops++ = cUNOPo->op_first;
2428         if (ops >= oplimit)
2429             Perl_croak(aTHX_ too_deep);
2430     }
2431     *ops = 0;
2432     if (o->op_flags & OPf_KIDS) {
2433         OP *kid;
2434         /* First try all the kids at this level, since that's likeliest. */
2435         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2436             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2437                 const char *kid_label = CopLABEL(kCOP);
2438                 if (kid_label && strEQ(kid_label, label))
2439                     return kid;
2440             }
2441         }
2442         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2443             if (kid == PL_lastgotoprobe)
2444                 continue;
2445             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2446                 if (ops == opstack)
2447                     *ops++ = kid;
2448                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2449                          ops[-1]->op_type == OP_DBSTATE)
2450                     ops[-1] = kid;
2451                 else
2452                     *ops++ = kid;
2453             }
2454             if ((o = dofindlabel(kid, label, ops, oplimit)))
2455                 return o;
2456         }
2457     }
2458     *ops = 0;
2459     return 0;
2460 }
2461
2462 PP(pp_goto)
2463 {
2464     dVAR; dSP;
2465     OP *retop = NULL;
2466     I32 ix;
2467     register PERL_CONTEXT *cx;
2468 #define GOTO_DEPTH 64
2469     OP *enterops[GOTO_DEPTH];
2470     const char *label = NULL;
2471     const bool do_dump = (PL_op->op_type == OP_DUMP);
2472     static const char must_have_label[] = "goto must have label";
2473
2474     if (PL_op->op_flags & OPf_STACKED) {
2475         SV * const sv = POPs;
2476
2477         /* This egregious kludge implements goto &subroutine */
2478         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2479             I32 cxix;
2480             register PERL_CONTEXT *cx;
2481             CV *cv = MUTABLE_CV(SvRV(sv));
2482             SV** mark;
2483             I32 items = 0;
2484             I32 oldsave;
2485             bool reified = 0;
2486
2487         retry:
2488             if (!CvROOT(cv) && !CvXSUB(cv)) {
2489                 const GV * const gv = CvGV(cv);
2490                 if (gv) {
2491                     GV *autogv;
2492                     SV *tmpstr;
2493                     /* autoloaded stub? */
2494                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2495                         goto retry;
2496                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2497                                           GvNAMELEN(gv), FALSE);
2498                     if (autogv && (cv = GvCV(autogv)))
2499                         goto retry;
2500                     tmpstr = sv_newmortal();
2501                     gv_efullname3(tmpstr, gv, NULL);
2502                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2503                 }
2504                 DIE(aTHX_ "Goto undefined subroutine");
2505             }
2506
2507             /* First do some returnish stuff. */
2508             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2509             FREETMPS;
2510             cxix = dopoptosub(cxstack_ix);
2511             if (cxix < 0)
2512                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2513             if (cxix < cxstack_ix)
2514                 dounwind(cxix);
2515             TOPBLOCK(cx);
2516             SPAGAIN;
2517             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2518             if (CxTYPE(cx) == CXt_EVAL) {
2519                 if (CxREALEVAL(cx))
2520                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2521                 else
2522                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2523             }
2524             else if (CxMULTICALL(cx))
2525                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2526             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2527                 /* put @_ back onto stack */
2528                 AV* av = cx->blk_sub.argarray;
2529
2530                 items = AvFILLp(av) + 1;
2531                 EXTEND(SP, items+1); /* @_ could have been extended. */
2532                 Copy(AvARRAY(av), SP + 1, items, SV*);
2533                 SvREFCNT_dec(GvAV(PL_defgv));
2534                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2535                 CLEAR_ARGARRAY(av);
2536                 /* abandon @_ if it got reified */
2537                 if (AvREAL(av)) {
2538                     reified = 1;
2539                     SvREFCNT_dec(av);
2540                     av = newAV();
2541                     av_extend(av, items-1);
2542                     AvREIFY_only(av);
2543                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2544                 }
2545             }
2546             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2547                 AV* const av = GvAV(PL_defgv);
2548                 items = AvFILLp(av) + 1;
2549                 EXTEND(SP, items+1); /* @_ could have been extended. */
2550                 Copy(AvARRAY(av), SP + 1, items, SV*);
2551             }
2552             mark = SP;
2553             SP += items;
2554             if (CxTYPE(cx) == CXt_SUB &&
2555                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2556                 SvREFCNT_dec(cx->blk_sub.cv);
2557             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2558             LEAVE_SCOPE(oldsave);
2559
2560             /* Now do some callish stuff. */
2561             SAVETMPS;
2562             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2563             if (CvISXSUB(cv)) {
2564                 OP* const retop = cx->blk_sub.retop;
2565                 SV **newsp;
2566                 I32 gimme;
2567                 if (reified) {
2568                     I32 index;
2569                     for (index=0; index<items; index++)
2570                         sv_2mortal(SP[-index]);
2571                 }
2572
2573                 /* XS subs don't have a CxSUB, so pop it */
2574                 POPBLOCK(cx, PL_curpm);
2575                 /* Push a mark for the start of arglist */
2576                 PUSHMARK(mark);
2577                 PUTBACK;
2578                 (void)(*CvXSUB(cv))(aTHX_ cv);
2579                 LEAVE;
2580                 return retop;
2581             }
2582             else {
2583                 AV* const padlist = CvPADLIST(cv);
2584                 if (CxTYPE(cx) == CXt_EVAL) {
2585                     PL_in_eval = CxOLD_IN_EVAL(cx);
2586                     PL_eval_root = cx->blk_eval.old_eval_root;
2587                     cx->cx_type = CXt_SUB;
2588                 }
2589                 cx->blk_sub.cv = cv;
2590                 cx->blk_sub.olddepth = CvDEPTH(cv);
2591
2592                 CvDEPTH(cv)++;
2593                 if (CvDEPTH(cv) < 2)
2594                     SvREFCNT_inc_simple_void_NN(cv);
2595                 else {
2596                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2597                         sub_crush_depth(cv);
2598                     pad_push(padlist, CvDEPTH(cv));
2599                 }
2600                 SAVECOMPPAD();
2601                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2602                 if (CxHASARGS(cx))
2603                 {
2604                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2605
2606                     cx->blk_sub.savearray = GvAV(PL_defgv);
2607                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2608                     CX_CURPAD_SAVE(cx->blk_sub);
2609                     cx->blk_sub.argarray = av;
2610
2611                     if (items >= AvMAX(av) + 1) {
2612                         SV **ary = AvALLOC(av);
2613                         if (AvARRAY(av) != ary) {
2614                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2615                             AvARRAY(av) = ary;
2616                         }
2617                         if (items >= AvMAX(av) + 1) {
2618                             AvMAX(av) = items - 1;
2619                             Renew(ary,items+1,SV*);
2620                             AvALLOC(av) = ary;
2621                             AvARRAY(av) = ary;
2622                         }
2623                     }
2624                     ++mark;
2625                     Copy(mark,AvARRAY(av),items,SV*);
2626                     AvFILLp(av) = items - 1;
2627                     assert(!AvREAL(av));
2628                     if (reified) {
2629                         /* transfer 'ownership' of refcnts to new @_ */
2630                         AvREAL_on(av);
2631                         AvREIFY_off(av);
2632                     }
2633                     while (items--) {
2634                         if (*mark)
2635                             SvTEMP_off(*mark);
2636                         mark++;
2637                     }
2638                 }
2639                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2640                     Perl_get_db_sub(aTHX_ NULL, cv);
2641                     if (PERLDB_GOTO) {
2642                         CV * const gotocv = get_cvs("DB::goto", 0);
2643                         if (gotocv) {
2644                             PUSHMARK( PL_stack_sp );
2645                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2646                             PL_stack_sp--;
2647                         }
2648                     }
2649                 }
2650                 RETURNOP(CvSTART(cv));
2651             }
2652         }
2653         else {
2654             label = SvPV_nolen_const(sv);
2655             if (!(do_dump || *label))
2656                 DIE(aTHX_ must_have_label);
2657         }
2658     }
2659     else if (PL_op->op_flags & OPf_SPECIAL) {
2660         if (! do_dump)
2661             DIE(aTHX_ must_have_label);
2662     }
2663     else
2664         label = cPVOP->op_pv;
2665
2666     PERL_ASYNC_CHECK();
2667
2668     if (label && *label) {
2669         OP *gotoprobe = NULL;
2670         bool leaving_eval = FALSE;
2671         bool in_block = FALSE;
2672         PERL_CONTEXT *last_eval_cx = NULL;
2673
2674         /* find label */
2675
2676         PL_lastgotoprobe = NULL;
2677         *enterops = 0;
2678         for (ix = cxstack_ix; ix >= 0; ix--) {
2679             cx = &cxstack[ix];
2680             switch (CxTYPE(cx)) {
2681             case CXt_EVAL:
2682                 leaving_eval = TRUE;
2683                 if (!CxTRYBLOCK(cx)) {
2684                     gotoprobe = (last_eval_cx ?
2685                                 last_eval_cx->blk_eval.old_eval_root :
2686                                 PL_eval_root);
2687                     last_eval_cx = cx;
2688                     break;
2689                 }
2690                 /* else fall through */
2691             case CXt_LOOP_LAZYIV:
2692             case CXt_LOOP_LAZYSV:
2693             case CXt_LOOP_FOR:
2694             case CXt_LOOP_PLAIN:
2695             case CXt_GIVEN:
2696             case CXt_WHEN:
2697                 gotoprobe = cx->blk_oldcop->op_sibling;
2698                 break;
2699             case CXt_SUBST:
2700                 continue;
2701             case CXt_BLOCK:
2702                 if (ix) {
2703                     gotoprobe = cx->blk_oldcop->op_sibling;
2704                     in_block = TRUE;
2705                 } else
2706                     gotoprobe = PL_main_root;
2707                 break;
2708             case CXt_SUB:
2709                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2710                     gotoprobe = CvROOT(cx->blk_sub.cv);
2711                     break;
2712                 }
2713                 /* FALL THROUGH */
2714             case CXt_FORMAT:
2715             case CXt_NULL:
2716                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2717             default:
2718                 if (ix)
2719                     DIE(aTHX_ "panic: goto");
2720                 gotoprobe = PL_main_root;
2721                 break;
2722             }
2723             if (gotoprobe) {
2724                 retop = dofindlabel(gotoprobe, label,
2725                                     enterops, enterops + GOTO_DEPTH);
2726                 if (retop)
2727                     break;
2728             }
2729             PL_lastgotoprobe = gotoprobe;
2730         }
2731         if (!retop)
2732             DIE(aTHX_ "Can't find label %s", label);
2733
2734         /* if we're leaving an eval, check before we pop any frames
2735            that we're not going to punt, otherwise the error
2736            won't be caught */
2737
2738         if (leaving_eval && *enterops && enterops[1]) {
2739             I32 i;
2740             for (i = 1; enterops[i]; i++)
2741                 if (enterops[i]->op_type == OP_ENTERITER)
2742                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2743         }
2744
2745         if (*enterops && enterops[1]) {
2746             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2747             if (enterops[i])
2748                 deprecate("\"goto\" to jump into a construct");
2749         }
2750
2751         /* pop unwanted frames */
2752
2753         if (ix < cxstack_ix) {
2754             I32 oldsave;
2755
2756             if (ix < 0)
2757                 ix = 0;
2758             dounwind(ix);
2759             TOPBLOCK(cx);
2760             oldsave = PL_scopestack[PL_scopestack_ix];
2761             LEAVE_SCOPE(oldsave);
2762         }
2763
2764         /* push wanted frames */
2765
2766         if (*enterops && enterops[1]) {
2767             OP * const oldop = PL_op;
2768             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2769             for (; enterops[ix]; ix++) {
2770                 PL_op = enterops[ix];
2771                 /* Eventually we may want to stack the needed arguments
2772                  * for each op.  For now, we punt on the hard ones. */
2773                 if (PL_op->op_type == OP_ENTERITER)
2774                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2775                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2776             }
2777             PL_op = oldop;
2778         }
2779     }
2780
2781     if (do_dump) {
2782 #ifdef VMS
2783         if (!retop) retop = PL_main_start;
2784 #endif
2785         PL_restartop = retop;
2786         PL_do_undump = TRUE;
2787
2788         my_unexec();
2789
2790         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2791         PL_do_undump = FALSE;
2792     }
2793
2794     RETURNOP(retop);
2795 }
2796
2797 PP(pp_exit)
2798 {
2799     dVAR;
2800     dSP;
2801     I32 anum;
2802
2803     if (MAXARG < 1)
2804         anum = 0;
2805     else {
2806         anum = SvIVx(POPs);
2807 #ifdef VMS
2808         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2809             anum = 0;
2810         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2811 #endif
2812     }
2813     PL_exit_flags |= PERL_EXIT_EXPECTED;
2814 #ifdef PERL_MAD
2815     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2816     if (anum || !(PL_minus_c && PL_madskills))
2817         my_exit(anum);
2818 #else
2819     my_exit(anum);
2820 #endif
2821     PUSHs(&PL_sv_undef);
2822     RETURN;
2823 }
2824
2825 /* Eval. */
2826
2827 STATIC void
2828 S_save_lines(pTHX_ AV *array, SV *sv)
2829 {
2830     const char *s = SvPVX_const(sv);
2831     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2832     I32 line = 1;
2833
2834     PERL_ARGS_ASSERT_SAVE_LINES;
2835
2836     while (s && s < send) {
2837         const char *t;
2838         SV * const tmpstr = newSV_type(SVt_PVMG);
2839
2840         t = (const char *)memchr(s, '\n', send - s);
2841         if (t)
2842             t++;
2843         else
2844             t = send;
2845
2846         sv_setpvn(tmpstr, s, t - s);
2847         av_store(array, line++, tmpstr);
2848         s = t;
2849     }
2850 }
2851
2852 /*
2853 =for apidoc docatch
2854
2855 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2856
2857 0 is used as continue inside eval,
2858
2859 3 is used for a die caught by an inner eval - continue inner loop
2860
2861 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2862 establish a local jmpenv to handle exception traps.
2863
2864 =cut
2865 */
2866 STATIC OP *
2867 S_docatch(pTHX_ OP *o)
2868 {
2869     dVAR;
2870     int ret;
2871     OP * const oldop = PL_op;
2872     dJMPENV;
2873
2874 #ifdef DEBUGGING
2875     assert(CATCH_GET == TRUE);
2876 #endif
2877     PL_op = o;
2878
2879     JMPENV_PUSH(ret);
2880     switch (ret) {
2881     case 0:
2882         assert(cxstack_ix >= 0);
2883         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2884         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2885  redo_body:
2886         CALLRUNOPS(aTHX);
2887         break;
2888     case 3:
2889         /* die caught by an inner eval - continue inner loop */
2890         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2891             PL_restartjmpenv = NULL;
2892             PL_op = PL_restartop;
2893             PL_restartop = 0;
2894             goto redo_body;
2895         }
2896         /* FALL THROUGH */
2897     default:
2898         JMPENV_POP;
2899         PL_op = oldop;
2900         JMPENV_JUMP(ret);
2901         /* NOTREACHED */
2902     }
2903     JMPENV_POP;
2904     PL_op = oldop;
2905     return NULL;
2906 }
2907
2908 /* James Bond: Do you expect me to talk?
2909    Auric Goldfinger: No, Mr. Bond. I expect you to die.
2910
2911    This code is an ugly hack, doesn't work with lexicals in subroutines that are
2912    called more than once, and is only used by regcomp.c, for (?{}) blocks.
2913
2914    Currently it is not used outside the core code. Best if it stays that way.
2915 */
2916 OP *
2917 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2918 /* sv Text to convert to OP tree. */
2919 /* startop op_free() this to undo. */
2920 /* code Short string id of the caller. */
2921 {
2922     dVAR; dSP;                          /* Make POPBLOCK work. */
2923     PERL_CONTEXT *cx;
2924     SV **newsp;
2925     I32 gimme = G_VOID;
2926     I32 optype;
2927     OP dummy;
2928     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2929     char *tmpbuf = tbuf;
2930     char *safestr;
2931     int runtime;
2932     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2933     STRLEN len;
2934
2935     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2936
2937     ENTER_with_name("eval");
2938     lex_start(sv, NULL, FALSE);
2939     SAVETMPS;
2940     /* switch to eval mode */
2941
2942     if (IN_PERL_COMPILETIME) {
2943         SAVECOPSTASH_FREE(&PL_compiling);
2944         CopSTASH_set(&PL_compiling, PL_curstash);
2945     }
2946     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2947         SV * const sv = sv_newmortal();
2948         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2949                        code, (unsigned long)++PL_evalseq,
2950                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2951         tmpbuf = SvPVX(sv);
2952         len = SvCUR(sv);
2953     }
2954     else
2955         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2956                           (unsigned long)++PL_evalseq);
2957     SAVECOPFILE_FREE(&PL_compiling);
2958     CopFILE_set(&PL_compiling, tmpbuf+2);
2959     SAVECOPLINE(&PL_compiling);
2960     CopLINE_set(&PL_compiling, 1);
2961     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2962        deleting the eval's FILEGV from the stash before gv_check() runs
2963        (i.e. before run-time proper). To work around the coredump that
2964        ensues, we always turn GvMULTI_on for any globals that were
2965        introduced within evals. See force_ident(). GSAR 96-10-12 */
2966     safestr = savepvn(tmpbuf, len);
2967     SAVEDELETE(PL_defstash, safestr, len);
2968     SAVEHINTS();
2969 #ifdef OP_IN_REGISTER
2970     PL_opsave = op;
2971 #else
2972     SAVEVPTR(PL_op);
2973 #endif
2974
2975     /* we get here either during compilation, or via pp_regcomp at runtime */
2976     runtime = IN_PERL_RUNTIME;
2977     if (runtime)
2978         runcv = find_runcv(NULL);
2979
2980     PL_op = &dummy;
2981     PL_op->op_type = OP_ENTEREVAL;
2982     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2983     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2984     PUSHEVAL(cx, 0);
2985
2986     if (runtime)
2987         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2988     else
2989         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2990     POPBLOCK(cx,PL_curpm);
2991     POPEVAL(cx);
2992
2993     (*startop)->op_type = OP_NULL;
2994     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2995     lex_end();
2996     /* XXX DAPM do this properly one year */
2997     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2998     LEAVE_with_name("eval");
2999     if (IN_PERL_COMPILETIME)
3000         CopHINTS_set(&PL_compiling, PL_hints);
3001 #ifdef OP_IN_REGISTER
3002     op = PL_opsave;
3003 #endif
3004     PERL_UNUSED_VAR(newsp);
3005     PERL_UNUSED_VAR(optype);
3006
3007     return PL_eval_start;
3008 }
3009
3010
3011 /*
3012 =for apidoc find_runcv
3013
3014 Locate the CV corresponding to the currently executing sub or eval.
3015 If db_seqp is non_null, skip CVs that are in the DB package and populate
3016 *db_seqp with the cop sequence number at the point that the DB:: code was
3017 entered. (allows debuggers to eval in the scope of the breakpoint rather
3018 than in the scope of the debugger itself).
3019
3020 =cut
3021 */
3022
3023 CV*
3024 Perl_find_runcv(pTHX_ U32 *db_seqp)
3025 {
3026     dVAR;
3027     PERL_SI      *si;
3028
3029     if (db_seqp)
3030         *db_seqp = PL_curcop->cop_seq;
3031     for (si = PL_curstackinfo; si; si = si->si_prev) {
3032         I32 ix;
3033         for (ix = si->si_cxix; ix >= 0; ix--) {
3034             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3035             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3036                 CV * const cv = cx->blk_sub.cv;
3037                 /* skip DB:: code */
3038                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3039                     *db_seqp = cx->blk_oldcop->cop_seq;
3040                     continue;
3041                 }
3042                 return cv;
3043             }
3044             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3045                 return PL_compcv;
3046         }
3047     }
3048     return PL_main_cv;
3049 }
3050
3051
3052 /* Run yyparse() in a setjmp wrapper. Returns:
3053  *   0: yyparse() successful
3054  *   1: yyparse() failed
3055  *   3: yyparse() died
3056  */
3057 STATIC int
3058 S_try_yyparse(pTHX)
3059 {
3060     int ret;
3061     dJMPENV;
3062
3063     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3064     JMPENV_PUSH(ret);
3065     switch (ret) {
3066     case 0:
3067         ret = yyparse() ? 1 : 0;
3068         break;
3069     case 3:
3070         break;
3071     default:
3072         JMPENV_POP;
3073         JMPENV_JUMP(ret);
3074         /* NOTREACHED */
3075     }
3076     JMPENV_POP;
3077     return ret;
3078 }
3079
3080
3081 /* Compile a require/do, an eval '', or a /(?{...})/.
3082  * In the last case, startop is non-null, and contains the address of
3083  * a pointer that should be set to the just-compiled code.
3084  * outside is the lexically enclosing CV (if any) that invoked us.
3085  * Returns a bool indicating whether the compile was successful; if so,
3086  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3087  * pushes undef (also croaks if startop != NULL).
3088  */
3089
3090 STATIC bool
3091 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3092 {
3093     dVAR; dSP;
3094     OP * const saveop = PL_op;
3095     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3096     int yystatus;
3097
3098     PL_in_eval = (in_require
3099                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3100                   : EVAL_INEVAL);
3101
3102     PUSHMARK(SP);
3103
3104     SAVESPTR(PL_compcv);
3105     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3106     CvEVAL_on(PL_compcv);
3107     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3108     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3109
3110     CvOUTSIDE_SEQ(PL_compcv) = seq;
3111     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3112
3113     /* set up a scratch pad */
3114
3115     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3116     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3117
3118
3119     if (!PL_madskills)
3120         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3121
3122     /* make sure we compile in the right package */
3123
3124     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3125         SAVESPTR(PL_curstash);
3126         PL_curstash = CopSTASH(PL_curcop);
3127     }
3128     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3129     SAVESPTR(PL_beginav);
3130     PL_beginav = newAV();
3131     SAVEFREESV(PL_beginav);
3132     SAVESPTR(PL_unitcheckav);
3133     PL_unitcheckav = newAV();
3134     SAVEFREESV(PL_unitcheckav);
3135
3136 #ifdef PERL_MAD
3137     SAVEBOOL(PL_madskills);
3138     PL_madskills = 0;
3139 #endif
3140
3141     /* try to compile it */
3142
3143     PL_eval_root = NULL;
3144     PL_curcop = &PL_compiling;
3145     CopARYBASE_set(PL_curcop, 0);
3146     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3147         PL_in_eval |= EVAL_KEEPERR;
3148     else
3149         CLEAR_ERRSV();
3150
3151     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3152      * so honour CATCH_GET and trap it here if necessary */
3153
3154     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3155
3156     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3157         SV **newsp;                     /* Used by POPBLOCK. */
3158         PERL_CONTEXT *cx = NULL;
3159         I32 optype;                     /* Used by POPEVAL. */
3160         SV *namesv = NULL;
3161         const char *msg;
3162
3163         PERL_UNUSED_VAR(newsp);
3164         PERL_UNUSED_VAR(optype);
3165
3166         PL_op = saveop;
3167         if (PL_eval_root) {
3168             op_free(PL_eval_root);
3169             PL_eval_root = NULL;
3170         }
3171         if (yystatus != 3) {
3172             SP = PL_stack_base + POPMARK;       /* pop original mark */
3173             if (!startop) {
3174                 POPBLOCK(cx,PL_curpm);
3175                 POPEVAL(cx);
3176                 namesv = cx->blk_eval.old_namesv;
3177             }
3178         }
3179         lex_end();
3180         if (yystatus != 3)
3181             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3182
3183         msg = SvPVx_nolen_const(ERRSV);
3184         if (in_require) {
3185             if (!cx) {
3186                 /* If cx is still NULL, it means that we didn't go in the
3187                  * POPEVAL branch. */
3188                 cx = &cxstack[cxstack_ix];
3189                 assert(CxTYPE(cx) == CXt_EVAL);
3190                 namesv = cx->blk_eval.old_namesv;
3191             }
3192             (void)hv_store(GvHVn(PL_incgv),
3193                            SvPVX_const(namesv), SvCUR(namesv),
3194                            &PL_sv_undef, 0);
3195             Perl_croak(aTHX_ "%sCompilation failed in require",
3196                        *msg ? msg : "Unknown error\n");
3197         }
3198         else if (startop) {
3199             if (yystatus != 3) {
3200                 POPBLOCK(cx,PL_curpm);
3201                 POPEVAL(cx);
3202             }
3203             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3204                        (*msg ? msg : "Unknown error\n"));
3205         }
3206         else {
3207             if (!*msg) {
3208                 sv_setpvs(ERRSV, "Compilation error");
3209             }
3210         }
3211         PUSHs(&PL_sv_undef);
3212         PUTBACK;
3213         return FALSE;
3214     }
3215     CopLINE_set(&PL_compiling, 0);
3216     if (startop) {
3217         *startop = PL_eval_root;
3218     } else
3219         SAVEFREEOP(PL_eval_root);
3220
3221     /* Set the context for this new optree.
3222      * Propagate the context from the eval(). */
3223     if ((gimme & G_WANT) == G_VOID)
3224         scalarvoid(PL_eval_root);
3225     else if ((gimme & G_WANT) == G_ARRAY)
3226         list(PL_eval_root);
3227     else
3228         scalar(PL_eval_root);
3229
3230     DEBUG_x(dump_eval());
3231
3232     /* Register with debugger: */
3233     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3234         CV * const cv = get_cvs("DB::postponed", 0);
3235         if (cv) {
3236             dSP;
3237             PUSHMARK(SP);
3238             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3239             PUTBACK;
3240             call_sv(MUTABLE_SV(cv), G_DISCARD);
3241         }
3242     }
3243
3244     if (PL_unitcheckav)
3245         call_list(PL_scopestack_ix, PL_unitcheckav);
3246
3247     /* compiled okay, so do it */
3248
3249     CvDEPTH(PL_compcv) = 1;
3250     SP = PL_stack_base + POPMARK;               /* pop original mark */
3251     PL_op = saveop;                     /* The caller may need it. */
3252     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3253
3254     PUTBACK;
3255     return TRUE;
3256 }
3257
3258 STATIC PerlIO *
3259 S_check_type_and_open(pTHX_ const char *name)
3260 {
3261     Stat_t st;
3262     const int st_rc = PerlLIO_stat(name, &st);
3263
3264     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3265
3266     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3267         return NULL;
3268     }
3269
3270     return PerlIO_open(name, PERL_SCRIPT_MODE);
3271 }
3272
3273 #ifndef PERL_DISABLE_PMC
3274 STATIC PerlIO *
3275 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3276 {
3277     PerlIO *fp;
3278
3279     PERL_ARGS_ASSERT_DOOPEN_PM;
3280
3281     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3282         SV *const pmcsv = newSV(namelen + 2);
3283         char *const pmc = SvPVX(pmcsv);
3284         Stat_t pmcstat;
3285
3286         memcpy(pmc, name, namelen);
3287         pmc[namelen] = 'c';
3288         pmc[namelen + 1] = '\0';
3289
3290         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3291             fp = check_type_and_open(name);
3292         }
3293         else {
3294             fp = check_type_and_open(pmc);
3295         }
3296         SvREFCNT_dec(pmcsv);
3297     }
3298     else {
3299         fp = check_type_and_open(name);
3300     }
3301     return fp;
3302 }
3303 #else
3304 #  define doopen_pm(name, namelen) check_type_and_open(name)
3305 #endif /* !PERL_DISABLE_PMC */
3306
3307 PP(pp_require)
3308 {
3309     dVAR; dSP;
3310     register PERL_CONTEXT *cx;
3311     SV *sv;
3312     const char *name;
3313     STRLEN len;
3314     char * unixname;
3315     STRLEN unixlen;
3316 #ifdef VMS
3317     int vms_unixname = 0;
3318 #endif
3319     const char *tryname = NULL;
3320     SV *namesv = NULL;
3321     const I32 gimme = GIMME_V;
3322     int filter_has_file = 0;
3323     PerlIO *tryrsfp = NULL;
3324     SV *filter_cache = NULL;
3325     SV *filter_state = NULL;
3326     SV *filter_sub = NULL;
3327     SV *hook_sv = NULL;
3328     SV *encoding;
3329     OP *op;
3330
3331     sv = POPs;
3332     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3333         sv = new_version(sv);
3334         if (!sv_derived_from(PL_patchlevel, "version"))
3335             upg_version(PL_patchlevel, TRUE);
3336         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3337             if ( vcmp(sv,PL_patchlevel) <= 0 )
3338                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3339                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3340         }
3341         else {
3342             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3343                 I32 first = 0;
3344                 AV *lav;
3345                 SV * const req = SvRV(sv);
3346                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3347
3348                 /* get the left hand term */
3349                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3350
3351                 first  = SvIV(*av_fetch(lav,0,0));
3352                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3353                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3354                     || av_len(lav) > 1               /* FP with > 3 digits */
3355                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3356                    ) {
3357                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3358                         "%"SVf", stopped", SVfARG(vnormal(req)),
3359                         SVfARG(vnormal(PL_patchlevel)));
3360                 }
3361                 else { /* probably 'use 5.10' or 'use 5.8' */
3362                     SV *hintsv;
3363                     I32 second = 0;
3364
3365                     if (av_len(lav)>=1)
3366                         second = SvIV(*av_fetch(lav,1,0));
3367
3368                     second /= second >= 600  ? 100 : 10;
3369                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3370                                            (int)first, (int)second);
3371                     upg_version(hintsv, TRUE);
3372
3373                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3374                         "--this is only %"SVf", stopped",
3375                         SVfARG(vnormal(req)),
3376                         SVfARG(vnormal(sv_2mortal(hintsv))),
3377                         SVfARG(vnormal(PL_patchlevel)));
3378                 }
3379             }
3380         }
3381
3382         /* We do this only with use, not require. */
3383         if (PL_compcv &&
3384           /* If we request a version >= 5.9.5, load feature.pm with the
3385            * feature bundle that corresponds to the required version. */
3386                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3387             SV *const importsv = vnormal(sv);
3388             *SvPVX_mutable(importsv) = ':';
3389             ENTER_with_name("load_feature");
3390             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3391             LEAVE_with_name("load_feature");
3392         }
3393         /* If a version >= 5.11.0 is requested, strictures are on by default! */
3394         if (PL_compcv &&
3395                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3396             PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3397         }
3398
3399         RETPUSHYES;
3400     }
3401     name = SvPV_const(sv, len);
3402     if (!(name && len > 0 && *name))
3403         DIE(aTHX_ "Null filename used");
3404     TAINT_PROPER("require");
3405
3406
3407 #ifdef VMS
3408     /* The key in the %ENV hash is in the syntax of file passed as the argument
3409      * usually this is in UNIX format, but sometimes in VMS format, which
3410      * can result in a module being pulled in more than once.
3411      * To prevent this, the key must be stored in UNIX format if the VMS
3412      * name can be translated to UNIX.
3413      */
3414     if ((unixname = tounixspec(name, NULL)) != NULL) {
3415         unixlen = strlen(unixname);
3416         vms_unixname = 1;
3417     }
3418     else
3419 #endif
3420     {
3421         /* if not VMS or VMS name can not be translated to UNIX, pass it
3422          * through.
3423          */
3424         unixname = (char *) name;
3425         unixlen = len;
3426     }
3427     if (PL_op->op_type == OP_REQUIRE) {
3428         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3429                                           unixname, unixlen, 0);
3430         if ( svp ) {
3431             if (*svp != &PL_sv_undef)
3432                 RETPUSHYES;
3433             else
3434                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3435                             "Compilation failed in require", unixname);
3436         }
3437     }
3438
3439     /* prepare to compile file */
3440
3441     if (path_is_absolute(name)) {
3442         tryname = name;
3443         tryrsfp = doopen_pm(name, len);
3444     }
3445     if (!tryrsfp) {
3446         AV * const ar = GvAVn(PL_incgv);
3447         I32 i;
3448 #ifdef VMS
3449         if (vms_unixname)
3450 #endif
3451         {
3452             namesv = newSV_type(SVt_PV);
3453             for (i = 0; i <= AvFILL(ar); i++) {
3454                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3455
3456                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3457                     mg_get(dirsv);
3458                 if (SvROK(dirsv)) {
3459                     int count;
3460                     SV **svp;
3461                     SV *loader = dirsv;
3462
3463                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3464                         && !sv_isobject(loader))
3465                     {
3466                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3467                     }
3468
3469                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3470                                    PTR2UV(SvRV(dirsv)), name);
3471                     tryname = SvPVX_const(namesv);
3472                     tryrsfp = NULL;
3473
3474                     ENTER_with_name("call_INC");
3475                     SAVETMPS;
3476                     EXTEND(SP, 2);
3477
3478                     PUSHMARK(SP);
3479                     PUSHs(dirsv);
3480                     PUSHs(sv);
3481                     PUTBACK;
3482                     if (sv_isobject(loader))
3483                         count = call_method("INC", G_ARRAY);
3484                     else
3485                         count = call_sv(loader, G_ARRAY);
3486                     SPAGAIN;
3487
3488                     /* Adjust file name if the hook has set an %INC entry */
3489                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3490                     if (svp)
3491                         tryname = SvPV_nolen_const(*svp);
3492
3493                     if (count > 0) {
3494                         int i = 0;
3495                         SV *arg;
3496
3497                         SP -= count - 1;
3498                         arg = SP[i++];
3499
3500                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3501                             && !isGV_with_GP(SvRV(arg))) {
3502                             filter_cache = SvRV(arg);
3503                             SvREFCNT_inc_simple_void_NN(filter_cache);
3504
3505                             if (i < count) {
3506                                 arg = SP[i++];
3507                             }
3508                         }
3509
3510                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3511                             arg = SvRV(arg);
3512                         }
3513
3514                         if (isGV_with_GP(arg)) {
3515                             IO * const io = GvIO((const GV *)arg);
3516
3517                             ++filter_has_file;
3518
3519                             if (io) {
3520                                 tryrsfp = IoIFP(io);
3521                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3522                                     PerlIO_close(IoOFP(io));
3523                                 }
3524                                 IoIFP(io) = NULL;
3525                                 IoOFP(io) = NULL;
3526                             }
3527
3528                             if (i < count) {
3529                                 arg = SP[i++];
3530                             }
3531                         }
3532
3533                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3534                             filter_sub = arg;
3535                             SvREFCNT_inc_simple_void_NN(filter_sub);
3536
3537                             if (i < count) {
3538                                 filter_state = SP[i];
3539                                 SvREFCNT_inc_simple_void(filter_state);
3540                             }
3541                         }
3542
3543                         if (!tryrsfp && (filter_cache || filter_sub)) {
3544                             tryrsfp = PerlIO_open(BIT_BUCKET,
3545                                                   PERL_SCRIPT_MODE);
3546                         }
3547                         SP--;
3548                     }
3549
3550                     PUTBACK;
3551                     FREETMPS;
3552                     LEAVE_with_name("call_INC");
3553
3554                     if (tryrsfp) {
3555                         hook_sv = dirsv;
3556                         break;
3557                     }
3558
3559                     filter_has_file = 0;
3560                     if (filter_cache) {
3561                         SvREFCNT_dec(filter_cache);
3562                         filter_cache = NULL;
3563                     }
3564                     if (filter_state) {
3565                         SvREFCNT_dec(filter_state);
3566                         filter_state = NULL;
3567                     }
3568                     if (filter_sub) {
3569                         SvREFCNT_dec(filter_sub);
3570                         filter_sub = NULL;
3571                     }
3572                 }
3573                 else {
3574                   if (!path_is_absolute(name)
3575                   ) {
3576                     const char *dir;
3577                     STRLEN dirlen;
3578
3579                     if (SvOK(dirsv)) {
3580                         dir = SvPV_const(dirsv, dirlen);
3581                     } else {
3582                         dir = "";
3583                         dirlen = 0;
3584                     }
3585
3586 #ifdef VMS
3587                     char *unixdir;
3588                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3589                         continue;
3590                     sv_setpv(namesv, unixdir);
3591                     sv_catpv(namesv, unixname);
3592 #else
3593 #  ifdef __SYMBIAN32__
3594                     if (PL_origfilename[0] &&
3595                         PL_origfilename[1] == ':' &&
3596                         !(dir[0] && dir[1] == ':'))
3597                         Perl_sv_setpvf(aTHX_ namesv,
3598                                        "%c:%s\\%s",
3599                                        PL_origfilename[0],
3600                                        dir, name);
3601                     else
3602                         Perl_sv_setpvf(aTHX_ namesv,
3603                                        "%s\\%s",
3604                                        dir, name);
3605 #  else
3606                     /* The equivalent of
3607                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3608                        but without the need to parse the format string, or
3609                        call strlen on either pointer, and with the correct
3610                        allocation up front.  */
3611                     {
3612                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3613
3614                         memcpy(tmp, dir, dirlen);
3615                         tmp +=dirlen;
3616                         *tmp++ = '/';
3617                         /* name came from an SV, so it will have a '\0' at the
3618                            end that we can copy as part of this memcpy().  */
3619                         memcpy(tmp, name, len + 1);
3620
3621                         SvCUR_set(namesv, dirlen + len + 1);
3622
3623                         /* Don't even actually have to turn SvPOK_on() as we
3624                            access it directly with SvPVX() below.  */
3625                     }
3626 #  endif
3627 #endif
3628                     TAINT_PROPER("require");
3629                     tryname = SvPVX_const(namesv);
3630                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3631                     if (tryrsfp) {
3632                         if (tryname[0] == '.' && tryname[1] == '/') {
3633                             ++tryname;
3634                             while (*++tryname == '/');
3635                         }
3636                         break;
3637                     }
3638                     else if (errno == EMFILE)
3639                         /* no point in trying other paths if out of handles */
3640                         break;
3641                   }
3642                 }
3643             }
3644         }
3645     }
3646     SAVECOPFILE_FREE(&PL_compiling);
3647     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3648     SvREFCNT_dec(namesv);
3649     if (!tryrsfp) {
3650         if (PL_op->op_type == OP_REQUIRE) {
3651             const char *msgstr = name;
3652             if(errno == EMFILE) {
3653                 SV * const msg
3654                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3655                                                Strerror(errno)));
3656                 msgstr = SvPV_nolen_const(msg);
3657             } else {
3658                 if (namesv) {                   /* did we lookup @INC? */
3659                     AV * const ar = GvAVn(PL_incgv);
3660                     I32 i;
3661                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3662                         "%s in @INC%s%s (@INC contains:",
3663                         msgstr,
3664                         (instr(msgstr, ".h ")
3665                          ? " (change .h to .ph maybe?)" : ""),
3666                         (instr(msgstr, ".ph ")
3667                          ? " (did you run h2ph?)" : "")
3668                                                               ));
3669
3670                     for (i = 0; i <= AvFILL(ar); i++) {
3671                         sv_catpvs(msg, " ");
3672                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3673                     }
3674                     sv_catpvs(msg, ")");
3675                     msgstr = SvPV_nolen_const(msg);
3676                 }
3677             }
3678             DIE(aTHX_ "Can't locate %s", msgstr);
3679         }
3680
3681         RETPUSHUNDEF;
3682     }
3683     else
3684         SETERRNO(0, SS_NORMAL);
3685
3686     /* Assume success here to prevent recursive requirement. */
3687     /* name is never assigned to again, so len is still strlen(name)  */
3688     /* Check whether a hook in @INC has already filled %INC */
3689     if (!hook_sv) {
3690         (void)hv_store(GvHVn(PL_incgv),
3691                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3692     } else {
3693         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3694         if (!svp)
3695             (void)hv_store(GvHVn(PL_incgv),
3696                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3697     }
3698
3699     ENTER_with_name("eval");
3700     SAVETMPS;
3701     lex_start(NULL, tryrsfp, TRUE);
3702
3703     SAVEHINTS();
3704     PL_hints = 0;
3705     hv_clear(GvHV(PL_hintgv));
3706
3707     SAVECOMPILEWARNINGS();
3708     if (PL_dowarn & G_WARN_ALL_ON)
3709         PL_compiling.cop_warnings = pWARN_ALL ;
3710     else if (PL_dowarn & G_WARN_ALL_OFF)
3711         PL_compiling.cop_warnings = pWARN_NONE ;
3712     else
3713         PL_compiling.cop_warnings = pWARN_STD ;
3714
3715     if (filter_sub || filter_cache) {
3716         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3717            than hanging another SV from it. In turn, filter_add() optionally
3718            takes the SV to use as the filter (or creates a new SV if passed
3719            NULL), so simply pass in whatever value filter_cache has.  */
3720         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3721         IoLINES(datasv) = filter_has_file;
3722         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3723         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3724     }
3725
3726     /* switch to eval mode */
3727     PUSHBLOCK(cx, CXt_EVAL, SP);
3728     PUSHEVAL(cx, name);
3729     cx->blk_eval.retop = PL_op->op_next;
3730
3731     SAVECOPLINE(&PL_compiling);
3732     CopLINE_set(&PL_compiling, 0);
3733
3734     PUTBACK;
3735
3736     /* Store and reset encoding. */
3737     encoding = PL_encoding;
3738     PL_encoding = NULL;
3739
3740     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3741         op = DOCATCH(PL_eval_start);
3742     else
3743         op = PL_op->op_next;
3744
3745     /* Restore encoding. */
3746     PL_encoding = encoding;
3747
3748     return op;
3749 }
3750
3751 /* This is a op added to hold the hints hash for
3752    pp_entereval. The hash can be modified by the code
3753    being eval'ed, so we return a copy instead. */
3754
3755 PP(pp_hintseval)
3756 {
3757     dVAR;
3758     dSP;
3759     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3760     RETURN;
3761 }
3762
3763
3764 PP(pp_entereval)
3765 {
3766     dVAR; dSP;
3767     register PERL_CONTEXT *cx;
3768     SV *sv;
3769     const I32 gimme = GIMME_V;
3770     const U32 was = PL_breakable_sub_gen;
3771     char tbuf[TYPE_DIGITS(long) + 12];
3772     char *tmpbuf = tbuf;
3773     STRLEN len;
3774     CV* runcv;
3775     U32 seq;
3776     HV *saved_hh = NULL;
3777
3778     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3779         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3780     }
3781     sv = POPs;
3782
3783     TAINT_IF(SvTAINTED(sv));
3784     TAINT_PROPER("eval");
3785
3786     ENTER_with_name("eval");
3787     lex_start(sv, NULL, FALSE);
3788     SAVETMPS;
3789
3790     /* switch to eval mode */
3791
3792     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3793         SV * const temp_sv = sv_newmortal();
3794         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3795                        (unsigned long)++PL_evalseq,
3796                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3797         tmpbuf = SvPVX(temp_sv);
3798         len = SvCUR(temp_sv);
3799     }
3800     else
3801         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3802     SAVECOPFILE_FREE(&PL_compiling);
3803     CopFILE_set(&PL_compiling, tmpbuf+2);
3804     SAVECOPLINE(&PL_compiling);
3805     CopLINE_set(&PL_compiling, 1);
3806     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3807        deleting the eval's FILEGV from the stash before gv_check() runs
3808        (i.e. before run-time proper). To work around the coredump that
3809        ensues, we always turn GvMULTI_on for any globals that were
3810        introduced within evals. See force_ident(). GSAR 96-10-12 */
3811     SAVEHINTS();
3812     PL_hints = PL_op->op_targ;
3813     if (saved_hh) {
3814         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3815         SvREFCNT_dec(GvHV(PL_hintgv));
3816         GvHV(PL_hintgv) = saved_hh;
3817     }
3818     SAVECOMPILEWARNINGS();
3819     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3820     if (PL_compiling.cop_hints_hash) {
3821         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3822     }
3823     if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3824         /* The label, if present, is the first entry on the chain. So rather
3825            than writing a blank label in front of it (which involves an
3826            allocation), just use the next entry in the chain.  */
3827         PL_compiling.cop_hints_hash
3828             = PL_curcop->cop_hints_hash->refcounted_he_next;
3829         /* Check the assumption that this removed the label.  */
3830         assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3831                                     NULL) == NULL);
3832     }
3833     else
3834         PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3835     if (PL_compiling.cop_hints_hash) {
3836         HINTS_REFCNT_LOCK;
3837         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3838         HINTS_REFCNT_UNLOCK;
3839     }
3840     /* special case: an eval '' executed within the DB package gets lexically
3841      * placed in the first non-DB CV rather than the current CV - this
3842      * allows the debugger to execute code, find lexicals etc, in the
3843      * scope of the code being debugged. Passing &seq gets find_runcv
3844      * to do the dirty work for us */
3845     runcv = find_runcv(&seq);
3846
3847     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3848     PUSHEVAL(cx, 0);
3849     cx->blk_eval.retop = PL_op->op_next;
3850
3851     /* prepare to compile string */
3852
3853     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3854         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3855     PUTBACK;
3856
3857     if (doeval(gimme, NULL, runcv, seq)) {
3858         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3859             ? (PERLDB_LINE || PERLDB_SAVESRC)
3860             :  PERLDB_SAVESRC_NOSUBS) {
3861             /* Retain the filegv we created.  */
3862         } else {
3863             char *const safestr = savepvn(tmpbuf, len);
3864             SAVEDELETE(PL_defstash, safestr, len);
3865         }
3866         return DOCATCH(PL_eval_start);
3867     } else {
3868         /* We have already left the scope set up earler thanks to the LEAVE
3869            in doeval().  */
3870         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3871             ? (PERLDB_LINE || PERLDB_SAVESRC)
3872             :  PERLDB_SAVESRC_INVALID) {
3873             /* Retain the filegv we created.  */
3874         } else {
3875             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3876         }
3877         return PL_op->op_next;
3878     }
3879 }
3880
3881 PP(pp_leaveeval)
3882 {
3883     dVAR; dSP;
3884     register SV **mark;
3885     SV **newsp;
3886     PMOP *newpm;
3887     I32 gimme;
3888     register PERL_CONTEXT *cx;
3889     OP *retop;
3890     const U8 save_flags = PL_op -> op_flags;
3891     I32 optype;
3892     SV *namesv;
3893
3894     POPBLOCK(cx,newpm);
3895     POPEVAL(cx);
3896     namesv = cx->blk_eval.old_namesv;
3897     retop = cx->blk_eval.retop;
3898
3899     TAINT_NOT;
3900     if (gimme == G_VOID)
3901         MARK = newsp;
3902     else if (gimme == G_SCALAR) {
3903         MARK = newsp + 1;
3904         if (MARK <= SP) {
3905             if (SvFLAGS(TOPs) & SVs_TEMP)
3906                 *MARK = TOPs;
3907             else
3908                 *MARK = sv_mortalcopy(TOPs);
3909         }
3910         else {
3911             MEXTEND(mark,0);
3912             *MARK = &PL_sv_undef;
3913         }
3914         SP = MARK;
3915     }
3916     else {
3917         /* in case LEAVE wipes old return values */
3918         for (mark = newsp + 1; mark <= SP; mark++) {
3919             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3920                 *mark = sv_mortalcopy(*mark);
3921                 TAINT_NOT;      /* Each item is independent */
3922             }
3923         }
3924     }
3925     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3926
3927 #ifdef DEBUGGING
3928     assert(CvDEPTH(PL_compcv) == 1);
3929 #endif
3930     CvDEPTH(PL_compcv) = 0;
3931     lex_end();
3932
3933     if (optype == OP_REQUIRE &&
3934         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3935     {
3936         /* Unassume the success we assumed earlier. */
3937         (void)hv_delete(GvHVn(PL_incgv),
3938                         SvPVX_const(namesv), SvCUR(namesv),
3939                         G_DISCARD);
3940         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3941                                SVfARG(namesv));
3942         /* die_where() did LEAVE, or we won't be here */
3943     }
3944     else {
3945         LEAVE_with_name("eval");
3946         if (!(save_flags & OPf_SPECIAL)) {
3947             CLEAR_ERRSV();
3948         }
3949     }
3950
3951     RETURNOP(retop);
3952 }
3953
3954 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3955    close to the related Perl_create_eval_scope.  */
3956 void
3957 Perl_delete_eval_scope(pTHX)
3958 {
3959     SV **newsp;
3960     PMOP *newpm;
3961     I32 gimme;
3962     register PERL_CONTEXT *cx;
3963     I32 optype;
3964
3965     POPBLOCK(cx,newpm);
3966     POPEVAL(cx);
3967     PL_curpm = newpm;
3968     LEAVE_with_name("eval_scope");
3969     PERL_UNUSED_VAR(newsp);
3970     PERL_UNUSED_VAR(gimme);
3971     PERL_UNUSED_VAR(optype);
3972 }
3973
3974 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3975    also needed by Perl_fold_constants.  */
3976 PERL_CONTEXT *
3977 Perl_create_eval_scope(pTHX_ U32 flags)
3978 {
3979     PERL_CONTEXT *cx;
3980     const I32 gimme = GIMME_V;
3981
3982     ENTER_with_name("eval_scope");
3983     SAVETMPS;
3984
3985     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3986     PUSHEVAL(cx, 0);
3987
3988     PL_in_eval = EVAL_INEVAL;
3989     if (flags & G_KEEPERR)
3990         PL_in_eval |= EVAL_KEEPERR;
3991     else
3992         CLEAR_ERRSV();
3993     if (flags & G_FAKINGEVAL) {
3994         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3995     }
3996     return cx;
3997 }
3998
3999 PP(pp_entertry)
4000 {
4001     dVAR;
4002     PERL_CONTEXT * const cx = create_eval_scope(0);
4003     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4004     return DOCATCH(PL_op->op_next);
4005 }
4006
4007 PP(pp_leavetry)
4008 {
4009     dVAR; dSP;
4010     SV **newsp;
4011     PMOP *newpm;
4012     I32 gimme;
4013     register PERL_CONTEXT *cx;
4014     I32 optype;
4015
4016     POPBLOCK(cx,newpm);
4017     POPEVAL(cx);
4018     PERL_UNUSED_VAR(optype);
4019
4020     TAINT_NOT;
4021     if (gimme == G_VOID)
4022         SP = newsp;
4023     else if (gimme == G_SCALAR) {
4024         register SV **mark;
4025         MARK = newsp + 1;
4026         if (MARK <= SP) {
4027             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4028                 *MARK = TOPs;
4029             else
4030                 *MARK = sv_mortalcopy(TOPs);
4031         }
4032         else {
4033             MEXTEND(mark,0);
4034             *MARK = &PL_sv_undef;
4035         }
4036         SP = MARK;
4037     }
4038     else {
4039         /* in case LEAVE wipes old return values */
4040         register SV **mark;
4041         for (mark = newsp + 1; mark <= SP; mark++) {
4042             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4043                 *mark = sv_mortalcopy(*mark);
4044                 TAINT_NOT;      /* Each item is independent */
4045             }
4046         }
4047     }
4048     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4049
4050     LEAVE_with_name("eval_scope");
4051     CLEAR_ERRSV();
4052     RETURN;
4053 }
4054
4055 PP(pp_entergiven)
4056 {
4057     dVAR; dSP;
4058     register PERL_CONTEXT *cx;
4059     const I32 gimme = GIMME_V;
4060
4061     ENTER_with_name("given");
4062     SAVETMPS;
4063
4064     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4065
4066     PUSHBLOCK(cx, CXt_GIVEN, SP);
4067     PUSHGIVEN(cx);
4068
4069     RETURN;
4070 }
4071
4072 PP(pp_leavegiven)
4073 {
4074     dVAR; dSP;
4075     register PERL_CONTEXT *cx;
4076     I32 gimme;
4077     SV **newsp;
4078     PMOP *newpm;
4079     PERL_UNUSED_CONTEXT;
4080
4081     POPBLOCK(cx,newpm);
4082     assert(CxTYPE(cx) == CXt_GIVEN);
4083
4084     SP = newsp;
4085     PUTBACK;
4086
4087     PL_curpm = newpm;   /* pop $1 et al */
4088
4089     LEAVE_with_name("given");
4090
4091     return NORMAL;
4092 }
4093
4094 /* Helper routines used by pp_smartmatch */
4095 STATIC PMOP *
4096 S_make_matcher(pTHX_ REGEXP *re)
4097 {
4098     dVAR;
4099     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4100
4101     PERL_ARGS_ASSERT_MAKE_MATCHER;
4102
4103     PM_SETRE(matcher, ReREFCNT_inc(re));
4104
4105     SAVEFREEOP((OP *) matcher);
4106     ENTER_with_name("matcher"); SAVETMPS;
4107     SAVEOP();
4108     return matcher;
4109 }
4110
4111 STATIC bool
4112 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4113 {
4114     dVAR;
4115     dSP;
4116
4117     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4118
4119     PL_op = (OP *) matcher;
4120     XPUSHs(sv);
4121     PUTBACK;
4122     (void) pp_match();
4123     SPAGAIN;
4124     return (SvTRUEx(POPs));
4125 }
4126
4127 STATIC void
4128 S_destroy_matcher(pTHX_ PMOP *matcher)
4129 {
4130     dVAR;
4131
4132     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4133     PERL_UNUSED_ARG(matcher);
4134
4135     FREETMPS;
4136     LEAVE_with_name("matcher");
4137 }
4138
4139 /* Do a smart match */
4140 PP(pp_smartmatch)
4141 {
4142     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4143     return do_smartmatch(NULL, NULL);
4144 }
4145
4146 /* This version of do_smartmatch() implements the
4147  * table of smart matches that is found in perlsyn.
4148  */
4149 STATIC OP *
4150 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4151 {
4152     dVAR;
4153     dSP;
4154
4155     bool object_on_left = FALSE;
4156     SV *e = TOPs;       /* e is for 'expression' */
4157     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4158
4159     /* First of all, handle overload magic of the rightmost argument */
4160     if (SvAMAGIC(e)) {
4161         SV * tmpsv;
4162         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4163         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4164
4165         tmpsv = amagic_call(d, e, smart_amg, 0);
4166         if (tmpsv) {
4167             SPAGAIN;
4168             (void)POPs;
4169             SETs(tmpsv);
4170             RETURN;
4171         }
4172         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4173     }
4174
4175     SP -= 2;    /* Pop the values */
4176
4177     /* Take care only to invoke mg_get() once for each argument.
4178      * Currently we do this by copying the SV if it's magical. */
4179     if (d) {
4180         if (SvGMAGICAL(d))
4181             d = sv_mortalcopy(d);
4182     }
4183     else
4184         d = &PL_sv_undef;
4185
4186     assert(e);
4187     if (SvGMAGICAL(e))
4188         e = sv_mortalcopy(e);
4189
4190     /* ~~ undef */
4191     if (!SvOK(e)) {
4192         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4193         if (SvOK(d))
4194             RETPUSHNO;
4195         else
4196             RETPUSHYES;
4197     }
4198
4199     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4200         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4201         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4202     }
4203     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4204         object_on_left = TRUE;
4205
4206     /* ~~ sub */
4207     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4208         I32 c;
4209         if (object_on_left) {
4210             goto sm_any_sub; /* Treat objects like scalars */
4211         }
4212         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4213             /* Test sub truth for each key */
4214             HE *he;
4215             bool andedresults = TRUE;
4216             HV *hv = (HV*) SvRV(d);
4217             I32 numkeys = hv_iterinit(hv);
4218             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4219             if (numkeys == 0)
4220                 RETPUSHYES;
4221             while ( (he = hv_iternext(hv)) ) {
4222                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4223                 ENTER_with_name("smartmatch_hash_key_test");
4224                 SAVETMPS;
4225                 PUSHMARK(SP);
4226                 PUSHs(hv_iterkeysv(he));
4227                 PUTBACK;
4228                 c = call_sv(e, G_SCALAR);
4229                 SPAGAIN;
4230                 if (c == 0)
4231                     andedresults = FALSE;
4232                 else
4233                     andedresults = SvTRUEx(POPs) && andedresults;
4234                 FREETMPS;
4235                 LEAVE_with_name("smartmatch_hash_key_test");
4236             }
4237             if (andedresults)
4238                 RETPUSHYES;
4239             else
4240                 RETPUSHNO;
4241         }
4242         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4243             /* Test sub truth for each element */
4244             I32 i;
4245             bool andedresults = TRUE;
4246             AV *av = (AV*) SvRV(d);
4247             const I32 len = av_len(av);
4248             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4249             if (len == -1)
4250                 RETPUSHYES;
4251             for (i = 0; i <= len; ++i) {
4252                 SV * const * const svp = av_fetch(av, i, FALSE);
4253                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4254                 ENTER_with_name("smartmatch_array_elem_test");
4255                 SAVETMPS;
4256                 PUSHMARK(SP);
4257                 if (svp)
4258                     PUSHs(*svp);
4259                 PUTBACK;
4260                 c = call_sv(e, G_SCALAR);
4261                 SPAGAIN;
4262                 if (c == 0)
4263                     andedresults = FALSE;
4264                 else
4265                     andedresults = SvTRUEx(POPs) && andedresults;
4266                 FREETMPS;
4267                 LEAVE_with_name("smartmatch_array_elem_test");
4268             }
4269             if (andedresults)
4270                 RETPUSHYES;
4271             else
4272                 RETPUSHNO;
4273         }
4274         else {
4275           sm_any_sub:
4276             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4277             ENTER_with_name("smartmatch_coderef");
4278             SAVETMPS;
4279             PUSHMARK(SP);
4280             PUSHs(d);
4281             PUTBACK;
4282             c = call_sv(e, G_SCALAR);
4283             SPAGAIN;
4284             if (c == 0)
4285                 PUSHs(&PL_sv_no);
4286             else if (SvTEMP(TOPs))
4287                 SvREFCNT_inc_void(TOPs);
4288             FREETMPS;
4289             LEAVE_with_name("smartmatch_coderef");
4290             RETURN;
4291         }
4292     }
4293     /* ~~ %hash */
4294     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4295         if (object_on_left) {
4296             goto sm_any_hash; /* Treat objects like scalars */
4297         }
4298         else if (!SvOK(d)) {
4299             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4300             RETPUSHNO;
4301         }
4302         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4303             /* Check that the key-sets are identical */
4304             HE *he;
4305             HV *other_hv = MUTABLE_HV(SvRV(d));
4306             bool tied = FALSE;
4307             bool other_tied = FALSE;
4308             U32 this_key_count  = 0,
4309                 other_key_count = 0;
4310             HV *hv = MUTABLE_HV(SvRV(e));
4311
4312             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4313             /* Tied hashes don't know how many keys they have. */
4314             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4315                 tied = TRUE;
4316             }
4317             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4318                 HV * const temp = other_hv;
4319                 other_hv = hv;
4320                 hv = temp;
4321                 tied = TRUE;
4322             }
4323             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4324                 other_tied = TRUE;
4325
4326             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4327                 RETPUSHNO;
4328
4329             /* The hashes have the same number of keys, so it suffices
4330                to check that one is a subset of the other. */
4331             (void) hv_iterinit(hv);
4332             while ( (he = hv_iternext(hv)) ) {
4333                 SV *key = hv_iterkeysv(he);
4334
4335                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4336                 ++ this_key_count;
4337
4338                 if(!hv_exists_ent(other_hv, key, 0)) {
4339                     (void) hv_iterinit(hv);     /* reset iterator */
4340                     RETPUSHNO;
4341                 }
4342             }
4343
4344             if (other_tied) {
4345                 (void) hv_iterinit(other_hv);
4346                 while ( hv_iternext(other_hv) )
4347                     ++other_key_count;
4348             }
4349             else
4350                 other_key_count = HvUSEDKEYS(other_hv);
4351
4352             if (this_key_count != other_key_count)
4353                 RETPUSHNO;
4354             else
4355                 RETPUSHYES;
4356         }
4357         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4358             AV * const other_av = MUTABLE_AV(SvRV(d));
4359             const I32 other_len = av_len(other_av) + 1;
4360             I32 i;
4361             HV *hv = MUTABLE_HV(SvRV(e));
4362
4363             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4364             for (i = 0; i < other_len; ++i) {
4365                 SV ** const svp = av_fetch(other_av, i, FALSE);
4366                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4367                 if (svp) {      /* ??? When can this not happen? */
4368                     if (hv_exists_ent(hv, *svp, 0))
4369                         RETPUSHYES;
4370                 }
4371             }
4372             RETPUSHNO;
4373         }
4374         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4375             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4376           sm_regex_hash:
4377             {
4378                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4379                 HE *he;
4380                 HV *hv = MUTABLE_HV(SvRV(e));
4381
4382                 (void) hv_iterinit(hv);
4383                 while ( (he = hv_iternext(hv)) ) {
4384                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4385                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4386                         (void) hv_iterinit(hv);
4387                         destroy_matcher(matcher);
4388                         RETPUSHYES;
4389                     }
4390                 }
4391                 destroy_matcher(matcher);
4392                 RETPUSHNO;
4393             }
4394         }
4395         else {
4396           sm_any_hash:
4397             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4398             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4399                 RETPUSHYES;
4400             else
4401                 RETPUSHNO;
4402         }
4403     }
4404     /* ~~ @array */
4405     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4406         if (object_on_left) {
4407             goto sm_any_array; /* Treat objects like scalars */
4408         }
4409         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4410             AV * const other_av = MUTABLE_AV(SvRV(e));
4411             const I32 other_len = av_len(other_av) + 1;
4412             I32 i;
4413
4414             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4415             for (i = 0; i < other_len; ++i) {
4416                 SV ** const svp = av_fetch(other_av, i, FALSE);
4417
4418                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4419                 if (svp) {      /* ??? When can this not happen? */
4420                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4421                         RETPUSHYES;
4422                 }
4423             }
4424             RETPUSHNO;
4425         }
4426         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4427             AV *other_av = MUTABLE_AV(SvRV(d));
4428             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4429             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4430                 RETPUSHNO;
4431             else {
4432                 I32 i;
4433                 const I32 other_len = av_len(other_av);
4434
4435                 if (NULL == seen_this) {
4436                     seen_this = newHV();
4437                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4438                 }
4439                 if (NULL == seen_other) {
4440                     seen_other = newHV();
4441                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4442                 }
4443                 for(i = 0; i <= other_len; ++i) {
4444                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4445                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4446
4447                     if (!this_elem || !other_elem) {
4448                         if ((this_elem && SvOK(*this_elem))
4449                                 || (other_elem && SvOK(*other_elem)))
4450                             RETPUSHNO;
4451                     }
4452                     else if (hv_exists_ent(seen_this,
4453                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4454                             hv_exists_ent(seen_other,
4455                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4456                     {
4457                         if (*this_elem != *other_elem)
4458                             RETPUSHNO;
4459                     }
4460                     else {
4461                         (void)hv_store_ent(seen_this,
4462                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4463                                 &PL_sv_undef, 0);
4464                         (void)hv_store_ent(seen_other,
4465                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4466                                 &PL_sv_undef, 0);
4467                         PUSHs(*other_elem);
4468                         PUSHs(*this_elem);
4469
4470                         PUTBACK;
4471                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4472                         (void) do_smartmatch(seen_this, seen_other);
4473                         SPAGAIN;
4474                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4475
4476                         if (!SvTRUEx(POPs))
4477                             RETPUSHNO;
4478                     }
4479                 }
4480                 RETPUSHYES;
4481             }
4482         }
4483         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4484             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4485           sm_regex_array:
4486             {
4487                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4488                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4489                 I32 i;
4490
4491                 for(i = 0; i <= this_len; ++i) {
4492                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4493                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4494                     if (svp && matcher_matches_sv(matcher, *svp)) {
4495                         destroy_matcher(matcher);
4496                         RETPUSHYES;
4497                     }
4498                 }
4499                 destroy_matcher(matcher);
4500                 RETPUSHNO;
4501             }
4502         }
4503         else if (!SvOK(d)) {
4504             /* undef ~~ array */
4505             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4506             I32 i;
4507
4508             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4509             for (i = 0; i <= this_len; ++i) {
4510                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4511                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4512                 if (!svp || !SvOK(*svp))
4513                     RETPUSHYES;
4514             }
4515             RETPUSHNO;
4516         }
4517         else {
4518           sm_any_array:
4519             {
4520                 I32 i;
4521                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4522
4523                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4524                 for (i = 0; i <= this_len; ++i) {
4525                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4526                     if (!svp)
4527                         continue;
4528
4529                     PUSHs(d);
4530                     PUSHs(*svp);
4531                     PUTBACK;
4532                     /* infinite recursion isn't supposed to happen here */
4533                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4534                     (void) do_smartmatch(NULL, NULL);
4535                     SPAGAIN;
4536                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4537                     if (SvTRUEx(POPs))
4538                         RETPUSHYES;
4539                 }
4540                 RETPUSHNO;
4541             }
4542         }
4543     }
4544     /* ~~ qr// */
4545     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4546         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4547             SV *t = d; d = e; e = t;
4548             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4549             goto sm_regex_hash;
4550         }
4551         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4552             SV *t = d; d = e; e = t;
4553             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4554             goto sm_regex_array;
4555         }
4556         else {
4557             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4558
4559             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4560             PUTBACK;
4561             PUSHs(matcher_matches_sv(matcher, d)
4562                     ? &PL_sv_yes
4563                     : &PL_sv_no);
4564             destroy_matcher(matcher);
4565             RETURN;
4566         }
4567     }
4568     /* ~~ scalar */
4569     /* See if there is overload magic on left */
4570     else if (object_on_left && SvAMAGIC(d)) {
4571         SV *tmpsv;
4572         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4573         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4574         PUSHs(d); PUSHs(e);
4575         PUTBACK;
4576         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4577         if (tmpsv) {
4578             SPAGAIN;
4579             (void)POPs;
4580             SETs(tmpsv);
4581             RETURN;
4582         }
4583         SP -= 2;
4584         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4585         goto sm_any_scalar;
4586     }
4587     else if (!SvOK(d)) {
4588         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4589         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4590         RETPUSHNO;
4591     }
4592     else
4593   sm_any_scalar:
4594     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4595         DEBUG_M(if (SvNIOK(e))
4596                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4597                 else
4598                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4599         );
4600         /* numeric comparison */
4601         PUSHs(d); PUSHs(e);
4602         PUTBACK;
4603         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4604             (void) pp_i_eq();
4605         else
4606             (void) pp_eq();
4607         SPAGAIN;
4608         if (SvTRUEx(POPs))
4609             RETPUSHYES;
4610         else
4611             RETPUSHNO;
4612     }
4613
4614     /* As a last resort, use string comparison */
4615     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4616     PUSHs(d); PUSHs(e);
4617     PUTBACK;
4618     return pp_seq();
4619 }
4620
4621 PP(pp_enterwhen)
4622 {
4623     dVAR; dSP;
4624     register PERL_CONTEXT *cx;
4625     const I32 gimme = GIMME_V;
4626
4627     /* This is essentially an optimization: if the match
4628        fails, we don't want to push a context and then
4629        pop it again right away, so we skip straight
4630        to the op that follows the leavewhen.
4631     */
4632     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4633         return cLOGOP->op_other->op_next;
4634
4635     ENTER_with_name("eval");
4636     SAVETMPS;
4637
4638     PUSHBLOCK(cx, CXt_WHEN, SP);
4639     PUSHWHEN(cx);
4640
4641     RETURN;
4642 }
4643
4644 PP(pp_leavewhen)
4645 {
4646     dVAR; dSP;
4647     register PERL_CONTEXT *cx;
4648     I32 gimme;
4649     SV **newsp;
4650     PMOP *newpm;
4651
4652     POPBLOCK(cx,newpm);
4653     assert(CxTYPE(cx) == CXt_WHEN);
4654
4655     SP = newsp;
4656     PUTBACK;
4657
4658     PL_curpm = newpm;   /* pop $1 et al */
4659
4660     LEAVE_with_name("eval");
4661     return NORMAL;
4662 }
4663
4664 PP(pp_continue)
4665 {
4666     dVAR;
4667     I32 cxix;
4668     register PERL_CONTEXT *cx;
4669     I32 inner;
4670
4671     cxix = dopoptowhen(cxstack_ix);
4672     if (cxix < 0)
4673         DIE(aTHX_ "Can't \"continue\" outside a when block");
4674     if (cxix < cxstack_ix)
4675         dounwind(cxix);
4676
4677     /* clear off anything above the scope we're re-entering */
4678     inner = PL_scopestack_ix;
4679     TOPBLOCK(cx);
4680     if (PL_scopestack_ix < inner)
4681         leave_scope(PL_scopestack[PL_scopestack_ix]);
4682     PL_curcop = cx->blk_oldcop;
4683     return cx->blk_givwhen.leave_op;
4684 }
4685
4686 PP(pp_break)
4687 {
4688     dVAR;
4689     I32 cxix;
4690     register PERL_CONTEXT *cx;
4691     I32 inner;
4692
4693     cxix = dopoptogiven(cxstack_ix);
4694     if (cxix < 0) {
4695         if (PL_op->op_flags & OPf_SPECIAL)
4696             DIE(aTHX_ "Can't use when() outside a topicalizer");
4697         else
4698             DIE(aTHX_ "Can't \"break\" outside a given block");
4699     }
4700     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4701         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4702
4703     if (cxix < cxstack_ix)
4704         dounwind(cxix);
4705
4706     /* clear off anything above the scope we're re-entering */
4707     inner = PL_scopestack_ix;
4708     TOPBLOCK(cx);
4709     if (PL_scopestack_ix < inner)
4710         leave_scope(PL_scopestack[PL_scopestack_ix]);
4711     PL_curcop = cx->blk_oldcop;
4712
4713     if (CxFOREACH(cx))
4714         return CX_LOOP_NEXTOP_GET(cx);
4715     else
4716         return cx->blk_givwhen.leave_op;
4717 }
4718
4719 STATIC OP *
4720 S_doparseform(pTHX_ SV *sv)
4721 {
4722     STRLEN len;
4723     register char *s = SvPV_force(sv, len);
4724     register char * const send = s + len;
4725     register char *base = NULL;
4726     register I32 skipspaces = 0;
4727     bool noblank   = FALSE;
4728     bool repeat    = FALSE;
4729     bool postspace = FALSE;
4730     U32 *fops;
4731     register U32 *fpc;
4732     U32 *linepc = NULL;
4733     register I32 arg;
4734     bool ischop;
4735     bool unchopnum = FALSE;
4736     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4737
4738     PERL_ARGS_ASSERT_DOPARSEFORM;
4739
4740     if (len == 0)
4741         Perl_croak(aTHX_ "Null picture in formline");
4742
4743     /* estimate the buffer size needed */
4744     for (base = s; s <= send; s++) {
4745         if (*s == '\n' || *s == '@' || *s == '^')
4746             maxops += 10;
4747     }
4748     s = base;
4749     base = NULL;
4750
4751     Newx(fops, maxops, U32);
4752     fpc = fops;
4753
4754     if (s < send) {
4755         linepc = fpc;
4756         *fpc++ = FF_LINEMARK;
4757         noblank = repeat = FALSE;
4758         base = s;
4759     }
4760
4761     while (s <= send) {
4762         switch (*s++) {
4763         default:
4764             skipspaces = 0;
4765             continue;
4766
4767         case '~':
4768             if (*s == '~') {
4769                 repeat = TRUE;
4770                 *s = ' ';
4771             }
4772             noblank = TRUE;
4773             s[-1] = ' ';
4774             /* FALL THROUGH */
4775         case ' ': case '\t':
4776             skipspaces++;
4777             continue;
4778         case 0:
4779             if (s < send) {
4780                 skipspaces = 0;
4781                 continue;
4782             } /* else FALL THROUGH */
4783         case '\n':
4784             arg = s - base;
4785             skipspaces++;
4786             arg -= skipspaces;
4787             if (arg) {
4788                 if (postspace)
4789                     *fpc++ = FF_SPACE;
4790                 *fpc++ = FF_LITERAL;
4791                 *fpc++ = (U16)arg;
4792             }
4793             postspace = FALSE;
4794             if (s <= send)
4795                 skipspaces--;
4796             if (skipspaces) {
4797                 *fpc++ = FF_SKIP;
4798                 *fpc++ = (U16)skipspaces;
4799             }
4800             skipspaces = 0;
4801             if (s <= send)
4802                 *fpc++ = FF_NEWLINE;
4803             if (noblank) {
4804                 *fpc++ = FF_BLANK;
4805                 if (repeat)
4806                     arg = fpc - linepc + 1;
4807                 else
4808                     arg = 0;
4809                 *fpc++ = (U16)arg;
4810             }
4811             if (s < send) {
4812                 linepc = fpc;
4813                 *fpc++ = FF_LINEMARK;
4814                 noblank = repeat = FALSE;
4815                 base = s;
4816             }
4817             else
4818                 s++;
4819             continue;
4820
4821         case '@':
4822         case '^':
4823             ischop = s[-1] == '^';
4824
4825             if (postspace) {
4826                 *fpc++ = FF_SPACE;
4827                 postspace = FALSE;
4828             }
4829             arg = (s - base) - 1;
4830             if (arg) {
4831                 *fpc++ = FF_LITERAL;
4832                 *fpc++ = (U16)arg;
4833             }
4834
4835             base = s - 1;
4836             *fpc++ = FF_FETCH;
4837             if (*s == '*') {
4838                 s++;
4839                 *fpc++ = 2;  /* skip the @* or ^* */
4840                 if (ischop) {
4841                     *fpc++ = FF_LINESNGL;
4842                     *fpc++ = FF_CHOP;
4843                 } else
4844                     *fpc++ = FF_LINEGLOB;
4845             }
4846             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4847                 arg = ischop ? 512 : 0;
4848                 base = s - 1;
4849                 while (*s == '#')
4850                     s++;
4851                 if (*s == '.') {
4852                     const char * const f = ++s;
4853                     while (*s == '#')
4854                         s++;
4855                     arg |= 256 + (s - f);
4856                 }
4857                 *fpc++ = s - base;              /* fieldsize for FETCH */
4858                 *fpc++ = FF_DECIMAL;
4859                 *fpc++ = (U16)arg;
4860                 unchopnum |= ! ischop;
4861             }
4862             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4863                 arg = ischop ? 512 : 0;
4864                 base = s - 1;
4865                 s++;                                /* skip the '0' first */
4866                 while (*s == '#')
4867                     s++;
4868                 if (*s == '.') {
4869                     const char * const f = ++s;
4870                     while (*s == '#')
4871                         s++;
4872                     arg |= 256 + (s - f);
4873                 }
4874                 *fpc++ = s - base;                /* fieldsize for FETCH */
4875                 *fpc++ = FF_0DECIMAL;
4876                 *fpc++ = (U16)arg;
4877                 unchopnum |= ! ischop;
4878             }
4879             else {
4880                 I32 prespace = 0;
4881                 bool ismore = FALSE;
4882
4883                 if (*s == '>') {
4884                     while (*++s == '>') ;
4885                     prespace = FF_SPACE;
4886                 }
4887                 else if (*s == '|') {
4888                     while (*++s == '|') ;
4889                     prespace = FF_HALFSPACE;
4890                     postspace = TRUE;
4891                 }
4892                 else {
4893                     if (*s == '<')
4894                         while (*++s == '<') ;
4895                     postspace = TRUE;
4896                 }
4897                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4898                     s += 3;
4899                     ismore = TRUE;
4900                 }
4901                 *fpc++ = s - base;              /* fieldsize for FETCH */
4902
4903                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4904
4905                 if (prespace)
4906                     *fpc++ = (U16)prespace;
4907                 *fpc++ = FF_ITEM;
4908                 if (ismore)
4909                     *fpc++ = FF_MORE;
4910                 if (ischop)
4911                     *fpc++ = FF_CHOP;
4912             }
4913             base = s;
4914             skipspaces = 0;
4915             continue;
4916         }
4917     }
4918     *fpc++ = FF_END;
4919
4920     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4921     arg = fpc - fops;
4922     { /* need to jump to the next word */
4923         int z;
4924         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4925         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4926         s = SvPVX(sv) + SvCUR(sv) + z;
4927     }
4928     Copy(fops, s, arg, U32);
4929     Safefree(fops);
4930     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4931     SvCOMPILED_on(sv);
4932
4933     if (unchopnum && repeat)
4934         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4935     return 0;
4936 }
4937
4938
4939 STATIC bool
4940 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4941 {
4942     /* Can value be printed in fldsize chars, using %*.*f ? */
4943     NV pwr = 1;
4944     NV eps = 0.5;
4945     bool res = FALSE;
4946     int intsize = fldsize - (value < 0 ? 1 : 0);
4947
4948     if (frcsize & 256)
4949         intsize--;
4950     frcsize &= 255;
4951     intsize -= frcsize;
4952
4953     while (intsize--) pwr *= 10.0;
4954     while (frcsize--) eps /= 10.0;
4955
4956     if( value >= 0 ){
4957         if (value + eps >= pwr)
4958             res = TRUE;
4959     } else {
4960         if (value - eps <= -pwr)
4961             res = TRUE;
4962     }
4963     return res;
4964 }
4965
4966 static I32
4967 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4968 {
4969     dVAR;
4970     SV * const datasv = FILTER_DATA(idx);
4971     const int filter_has_file = IoLINES(datasv);
4972     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4973     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4974     int status = 0;
4975     SV *upstream;
4976     STRLEN got_len;
4977     char *got_p = NULL;
4978     char *prune_from = NULL;
4979     bool read_from_cache = FALSE;
4980     STRLEN umaxlen;
4981
4982     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4983
4984     assert(maxlen >= 0);
4985     umaxlen = maxlen;
4986
4987     /* I was having segfault trouble under Linux 2.2.5 after a
4988        parse error occured.  (Had to hack around it with a test
4989        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4990        not sure where the trouble is yet.  XXX */
4991
4992     {
4993         SV *const cache = datasv;
4994         if (SvOK(cache)) {
4995             STRLEN cache_len;
4996             const char *cache_p = SvPV(cache, cache_len);
4997             STRLEN take = 0;
4998
4999             if (umaxlen) {
5000                 /* Running in block mode and we have some cached data already.
5001                  */
5002                 if (cache_len >= umaxlen) {
5003                     /* In fact, so much data we don't even need to call
5004                        filter_read.  */
5005                     take = umaxlen;
5006                 }
5007             } else {
5008                 const char *const first_nl =
5009                     (const char *)memchr(cache_p, '\n', cache_len);
5010                 if (first_nl) {
5011                     take = first_nl + 1 - cache_p;
5012                 }
5013             }
5014             if (take) {
5015                 sv_catpvn(buf_sv, cache_p, take);
5016                 sv_chop(cache, cache_p + take);
5017                 /* Definately not EOF  */
5018                 return 1;
5019             }
5020
5021             sv_catsv(buf_sv, cache);
5022             if (umaxlen) {
5023                 umaxlen -= cache_len;
5024             }
5025             SvOK_off(cache);
5026             read_from_cache = TRUE;
5027         }
5028     }
5029
5030     /* Filter API says that the filter appends to the contents of the buffer.
5031        Usually the buffer is "", so the details don't matter. But if it's not,
5032        then clearly what it contains is already filtered by this filter, so we
5033        don't want to pass it in a second time.
5034        I'm going to use a mortal in case the upstream filter croaks.  */
5035     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5036         ? sv_newmortal() : buf_sv;
5037     SvUPGRADE(upstream, SVt_PV);
5038
5039     if (filter_has_file) {
5040         status = FILTER_READ(idx+1, upstream, 0);
5041     }
5042
5043     if (filter_sub && status >= 0) {
5044         dSP;
5045         int count;
5046
5047         ENTER_with_name("call_filter_sub");
5048         SAVE_DEFSV;
5049         SAVETMPS;
5050         EXTEND(SP, 2);
5051
5052         DEFSV_set(upstream);
5053         PUSHMARK(SP);
5054         mPUSHi(0);
5055         if (filter_state) {
5056             PUSHs(filter_state);
5057         }
5058         PUTBACK;
5059         count = call_sv(filter_sub, G_SCALAR);
5060         SPAGAIN;
5061
5062         if (count > 0) {
5063             SV *out = POPs;
5064             if (SvOK(out)) {
5065                 status = SvIV(out);
5066             }
5067         }
5068
5069         PUTBACK;
5070         FREETMPS;
5071         LEAVE_with_name("call_filter_sub");
5072     }
5073
5074     if(SvOK(upstream)) {
5075         got_p = SvPV(upstream, got_len);
5076         if (umaxlen) {
5077             if (got_len > umaxlen) {
5078                 prune_from = got_p + umaxlen;
5079             }
5080         } else {
5081             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5082             if (first_nl && first_nl + 1 < got_p + got_len) {
5083                 /* There's a second line here... */
5084                 prune_from = first_nl + 1;
5085             }
5086         }
5087     }
5088     if (prune_from) {
5089         /* Oh. Too long. Stuff some in our cache.  */
5090         STRLEN cached_len = got_p + got_len - prune_from;
5091         SV *const cache = datasv;
5092
5093         if (SvOK(cache)) {
5094             /* Cache should be empty.  */
5095             assert(!SvCUR(cache));
5096         }
5097
5098         sv_setpvn(cache, prune_from, cached_len);
5099         /* If you ask for block mode, you may well split UTF-8 characters.
5100            "If it breaks, you get to keep both parts"
5101            (Your code is broken if you  don't put them back together again
5102            before something notices.) */
5103         if (SvUTF8(upstream)) {
5104             SvUTF8_on(cache);
5105         }
5106         SvCUR_set(upstream, got_len - cached_len);
5107         *prune_from = 0;
5108         /* Can't yet be EOF  */
5109         if (status == 0)
5110             status = 1;
5111     }
5112
5113     /* If they are at EOF but buf_sv has something in it, then they may never
5114        have touched the SV upstream, so it may be undefined.  If we naively
5115        concatenate it then we get a warning about use of uninitialised value.
5116     */
5117     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5118         sv_catsv(buf_sv, upstream);
5119     }
5120
5121     if (status <= 0) {
5122         IoLINES(datasv) = 0;
5123         if (filter_state) {
5124             SvREFCNT_dec(filter_state);
5125             IoTOP_GV(datasv) = NULL;
5126         }
5127         if (filter_sub) {
5128             SvREFCNT_dec(filter_sub);
5129             IoBOTTOM_GV(datasv) = NULL;
5130         }
5131         filter_del(S_run_user_filter);
5132     }
5133     if (status == 0 && read_from_cache) {
5134         /* If we read some data from the cache (and by getting here it implies
5135            that we emptied the cache) then we aren't yet at EOF, and mustn't
5136            report that to our caller.  */
5137         return 1;
5138     }
5139     return status;
5140 }
5141
5142 /* perhaps someone can come up with a better name for
5143    this?  it is not really "absolute", per se ... */
5144 static bool
5145 S_path_is_absolute(const char *name)
5146 {
5147     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5148
5149     if (PERL_FILE_IS_ABSOLUTE(name)
5150 #ifdef WIN32
5151         || (*name == '.' && ((name[1] == '/' ||
5152                              (name[1] == '.' && name[2] == '/'))
5153                          || (name[1] == '\\' ||
5154                              ( name[1] == '.' && name[2] == '\\')))
5155             )
5156 #else
5157         || (*name == '.' && (name[1] == '/' ||
5158                              (name[1] == '.' && name[2] == '/')))
5159 #endif
5160          )
5161     {
5162         return TRUE;
5163     }
5164     else
5165         return FALSE;
5166 }
5167
5168 /*
5169  * Local variables:
5170  * c-indentation-style: bsd
5171  * c-basic-offset: 4
5172  * indent-tabs-mode: t
5173  * End:
5174  *
5175  * ex: set ts=8 sts=4 sw=4 noet:
5176  */