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