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                         *++newsp = SvREFCNT_inc(*SP);
2374                         FREETMPS;
2375                         sv_2mortal(*newsp);
2376                 }
2377                 else
2378                     *++newsp =
2379                         !SvTEMP(*SP)
2380                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2381                           : *SP;
2382         }
2383         else {
2384             EXTEND(newsp,1);
2385             *++newsp = &PL_sv_undef;
2386         }
2387         if (CxLVAL(cx) & OPpDEREF) {
2388             SvGETMAGIC(TOPs);
2389             if (!SvOK(TOPs)) {
2390                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2391             }
2392         }
2393     }
2394     else if (gimme == G_ARRAY) {
2395         assert (!(CxLVAL(cx) & OPpDEREF));
2396         if (ref || !CxLVAL(cx))
2397             while (++MARK <= SP)
2398                 *++newsp =
2399                      SvTEMP(*MARK)
2400                        ? *MARK
2401                        : ref && SvFLAGS(*MARK) & SVs_PADTMP
2402                            ? sv_mortalcopy(*MARK)
2403                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2404         else while (++MARK <= SP) {
2405             if (*MARK != &PL_sv_undef
2406                     && (SvPADTMP(*MARK)
2407                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2408                              == SVf_READONLY
2409                        )
2410             ) {
2411                     SV *sv;
2412                     /* Might be flattened array after $#array =  */
2413                     PUTBACK;
2414                     LEAVE;
2415                     cxstack_ix--;
2416                     POPSUB(cx,sv);
2417                     PL_curpm = newpm;
2418                     LEAVESUB(sv);
2419                /* diag_listed_as: Can't return %s from lvalue subroutine */
2420                     Perl_croak(aTHX_
2421                         "Can't return a %s from lvalue subroutine",
2422                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2423             }
2424             else
2425                 *++newsp =
2426                     SvTEMP(*MARK)
2427                        ? *MARK
2428                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2429         }
2430     }
2431     PL_stack_sp = newsp;
2432 }
2433
2434 PP(pp_return)
2435 {
2436     dVAR; dSP; dMARK;
2437     register PERL_CONTEXT *cx;
2438     bool popsub2 = FALSE;
2439     bool clear_errsv = FALSE;
2440     bool lval = FALSE;
2441     I32 gimme;
2442     SV **newsp;
2443     PMOP *newpm;
2444     I32 optype = 0;
2445     SV *namesv;
2446     SV *sv;
2447     OP *retop = NULL;
2448
2449     const I32 cxix = dopoptosub(cxstack_ix);
2450
2451     if (cxix < 0) {
2452         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2453                                      * sort block, which is a CXt_NULL
2454                                      * not a CXt_SUB */
2455             dounwind(0);
2456             PL_stack_base[1] = *PL_stack_sp;
2457             PL_stack_sp = PL_stack_base + 1;
2458             return 0;
2459         }
2460         else
2461             DIE(aTHX_ "Can't return outside a subroutine");
2462     }
2463     if (cxix < cxstack_ix)
2464         dounwind(cxix);
2465
2466     if (CxMULTICALL(&cxstack[cxix])) {
2467         gimme = cxstack[cxix].blk_gimme;
2468         if (gimme == G_VOID)
2469             PL_stack_sp = PL_stack_base;
2470         else if (gimme == G_SCALAR) {
2471             PL_stack_base[1] = *PL_stack_sp;
2472             PL_stack_sp = PL_stack_base + 1;
2473         }
2474         return 0;
2475     }
2476
2477     POPBLOCK(cx,newpm);
2478     switch (CxTYPE(cx)) {
2479     case CXt_SUB:
2480         popsub2 = TRUE;
2481         lval = !!CvLVALUE(cx->blk_sub.cv);
2482         retop = cx->blk_sub.retop;
2483         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2484         break;
2485     case CXt_EVAL:
2486         if (!(PL_in_eval & EVAL_KEEPERR))
2487             clear_errsv = TRUE;
2488         POPEVAL(cx);
2489         namesv = cx->blk_eval.old_namesv;
2490         retop = cx->blk_eval.retop;
2491         if (CxTRYBLOCK(cx))
2492             break;
2493         if (optype == OP_REQUIRE &&
2494             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2495         {
2496             /* Unassume the success we assumed earlier. */
2497             (void)hv_delete(GvHVn(PL_incgv),
2498                             SvPVX_const(namesv),
2499                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2500                             G_DISCARD);
2501             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2502         }
2503         break;
2504     case CXt_FORMAT:
2505         POPFORMAT(cx);
2506         retop = cx->blk_sub.retop;
2507         break;
2508     default:
2509         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2510     }
2511
2512     TAINT_NOT;
2513     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2514     else {
2515       if (gimme == G_SCALAR) {
2516         if (MARK < SP) {
2517             if (popsub2) {
2518                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2519                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2520                          && !SvMAGICAL(TOPs)) {
2521                         *++newsp = SvREFCNT_inc(*SP);
2522                         FREETMPS;
2523                         sv_2mortal(*newsp);
2524                     }
2525                     else {
2526                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2527                         FREETMPS;
2528                         *++newsp = sv_mortalcopy(sv);
2529                         SvREFCNT_dec(sv);
2530                     }
2531                 }
2532                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2533                           && !SvMAGICAL(*SP)) {
2534                     *++newsp = *SP;
2535                 }
2536                 else
2537                     *++newsp = sv_mortalcopy(*SP);
2538             }
2539             else
2540                 *++newsp = sv_mortalcopy(*SP);
2541         }
2542         else
2543             *++newsp = &PL_sv_undef;
2544       }
2545       else if (gimme == G_ARRAY) {
2546         while (++MARK <= SP) {
2547             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2548                                && !SvGMAGICAL(*MARK)
2549                         ? *MARK : sv_mortalcopy(*MARK);
2550             TAINT_NOT;          /* Each item is independent */
2551         }
2552       }
2553       PL_stack_sp = newsp;
2554     }
2555
2556     LEAVE;
2557     /* Stack values are safe: */
2558     if (popsub2) {
2559         cxstack_ix--;
2560         POPSUB(cx,sv);  /* release CV and @_ ... */
2561     }
2562     else
2563         sv = NULL;
2564     PL_curpm = newpm;   /* ... and pop $1 et al */
2565
2566     LEAVESUB(sv);
2567     if (clear_errsv) {
2568         CLEAR_ERRSV();
2569     }
2570     return retop;
2571 }
2572
2573 /* This duplicates parts of pp_leavesub, so that it can share code with
2574  * pp_return */
2575 PP(pp_leavesublv)
2576 {
2577     dVAR; dSP;
2578     SV **newsp;
2579     PMOP *newpm;
2580     I32 gimme;
2581     register PERL_CONTEXT *cx;
2582     SV *sv;
2583
2584     if (CxMULTICALL(&cxstack[cxstack_ix]))
2585         return 0;
2586
2587     POPBLOCK(cx,newpm);
2588     cxstack_ix++; /* temporarily protect top context */
2589
2590     TAINT_NOT;
2591
2592     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2593
2594     LEAVE;
2595     cxstack_ix--;
2596     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2597     PL_curpm = newpm;   /* ... and pop $1 et al */
2598
2599     LEAVESUB(sv);
2600     return cx->blk_sub.retop;
2601 }
2602
2603 PP(pp_last)
2604 {
2605     dVAR; dSP;
2606     I32 cxix;
2607     register PERL_CONTEXT *cx;
2608     I32 pop2 = 0;
2609     I32 gimme;
2610     I32 optype;
2611     OP *nextop = NULL;
2612     SV **newsp;
2613     PMOP *newpm;
2614     SV **mark;
2615     SV *sv = NULL;
2616
2617
2618     if (PL_op->op_flags & OPf_SPECIAL) {
2619         cxix = dopoptoloop(cxstack_ix);
2620         if (cxix < 0)
2621             DIE(aTHX_ "Can't \"last\" outside a loop block");
2622     }
2623     else {
2624         cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2625                            (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2626         if (cxix < 0)
2627             DIE(aTHX_ "Label not found for \"last %"SVf"\"",
2628                                         SVfARG(newSVpvn_flags(cPVOP->op_pv,
2629                                                     strlen(cPVOP->op_pv),
2630                                                     ((cPVOP->op_private & OPpPV_IS_UTF8)
2631                                                     ? SVf_UTF8 : 0) | SVs_TEMP)));
2632     }
2633     if (cxix < cxstack_ix)
2634         dounwind(cxix);
2635
2636     POPBLOCK(cx,newpm);
2637     cxstack_ix++; /* temporarily protect top context */
2638     mark = newsp;
2639     switch (CxTYPE(cx)) {
2640     case CXt_LOOP_LAZYIV:
2641     case CXt_LOOP_LAZYSV:
2642     case CXt_LOOP_FOR:
2643     case CXt_LOOP_PLAIN:
2644         pop2 = CxTYPE(cx);
2645         newsp = PL_stack_base + cx->blk_loop.resetsp;
2646         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2647         break;
2648     case CXt_SUB:
2649         pop2 = CXt_SUB;
2650         nextop = cx->blk_sub.retop;
2651         break;
2652     case CXt_EVAL:
2653         POPEVAL(cx);
2654         nextop = cx->blk_eval.retop;
2655         break;
2656     case CXt_FORMAT:
2657         POPFORMAT(cx);
2658         nextop = cx->blk_sub.retop;
2659         break;
2660     default:
2661         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2662     }
2663
2664     TAINT_NOT;
2665     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2666                                 pop2 == CXt_SUB ? SVs_TEMP : 0);
2667     PUTBACK;
2668
2669     LEAVE;
2670     cxstack_ix--;
2671     /* Stack values are safe: */
2672     switch (pop2) {
2673     case CXt_LOOP_LAZYIV:
2674     case CXt_LOOP_PLAIN:
2675     case CXt_LOOP_LAZYSV:
2676     case CXt_LOOP_FOR:
2677         POPLOOP(cx);    /* release loop vars ... */
2678         LEAVE;
2679         break;
2680     case CXt_SUB:
2681         POPSUB(cx,sv);  /* release CV and @_ ... */
2682         break;
2683     }
2684     PL_curpm = newpm;   /* ... and pop $1 et al */
2685
2686     LEAVESUB(sv);
2687     PERL_UNUSED_VAR(optype);
2688     PERL_UNUSED_VAR(gimme);
2689     return nextop;
2690 }
2691
2692 PP(pp_next)
2693 {
2694     dVAR;
2695     I32 cxix;
2696     register PERL_CONTEXT *cx;
2697     I32 inner;
2698
2699     if (PL_op->op_flags & OPf_SPECIAL) {
2700         cxix = dopoptoloop(cxstack_ix);
2701         if (cxix < 0)
2702             DIE(aTHX_ "Can't \"next\" outside a loop block");
2703     }
2704     else {
2705         cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2706                            (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2707         if (cxix < 0)
2708             DIE(aTHX_ "Label not found for \"next %"SVf"\"",
2709                                         SVfARG(newSVpvn_flags(cPVOP->op_pv,
2710                                                     strlen(cPVOP->op_pv),
2711                                                     ((cPVOP->op_private & OPpPV_IS_UTF8)
2712                                                     ? SVf_UTF8 : 0) | SVs_TEMP)));
2713     }
2714     if (cxix < cxstack_ix)
2715         dounwind(cxix);
2716
2717     /* clear off anything above the scope we're re-entering, but
2718      * save the rest until after a possible continue block */
2719     inner = PL_scopestack_ix;
2720     TOPBLOCK(cx);
2721     if (PL_scopestack_ix < inner)
2722         leave_scope(PL_scopestack[PL_scopestack_ix]);
2723     PL_curcop = cx->blk_oldcop;
2724     return (cx)->blk_loop.my_op->op_nextop;
2725 }
2726
2727 PP(pp_redo)
2728 {
2729     dVAR;
2730     I32 cxix;
2731     register PERL_CONTEXT *cx;
2732     I32 oldsave;
2733     OP* redo_op;
2734
2735     if (PL_op->op_flags & OPf_SPECIAL) {
2736         cxix = dopoptoloop(cxstack_ix);
2737         if (cxix < 0)
2738             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2739     }
2740     else {
2741         cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2742                            (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2743         if (cxix < 0)
2744             DIE(aTHX_ "Label not found for \"redo %"SVf"\"",
2745                                         SVfARG(newSVpvn_flags(cPVOP->op_pv,
2746                                                     strlen(cPVOP->op_pv),
2747                                                     ((cPVOP->op_private & OPpPV_IS_UTF8)
2748                                                     ? SVf_UTF8 : 0) | SVs_TEMP)));
2749     }
2750     if (cxix < cxstack_ix)
2751         dounwind(cxix);
2752
2753     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2754     if (redo_op->op_type == OP_ENTER) {
2755         /* pop one less context to avoid $x being freed in while (my $x..) */
2756         cxstack_ix++;
2757         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2758         redo_op = redo_op->op_next;
2759     }
2760
2761     TOPBLOCK(cx);
2762     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2763     LEAVE_SCOPE(oldsave);
2764     FREETMPS;
2765     PL_curcop = cx->blk_oldcop;
2766     return redo_op;
2767 }
2768
2769 STATIC OP *
2770 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2771 {
2772     dVAR;
2773     OP **ops = opstack;
2774     static const char too_deep[] = "Target of goto is too deeply nested";
2775
2776     PERL_ARGS_ASSERT_DOFINDLABEL;
2777
2778     if (ops >= oplimit)
2779         Perl_croak(aTHX_ too_deep);
2780     if (o->op_type == OP_LEAVE ||
2781         o->op_type == OP_SCOPE ||
2782         o->op_type == OP_LEAVELOOP ||
2783         o->op_type == OP_LEAVESUB ||
2784         o->op_type == OP_LEAVETRY)
2785     {
2786         *ops++ = cUNOPo->op_first;
2787         if (ops >= oplimit)
2788             Perl_croak(aTHX_ too_deep);
2789     }
2790     *ops = 0;
2791     if (o->op_flags & OPf_KIDS) {
2792         OP *kid;
2793         /* First try all the kids at this level, since that's likeliest. */
2794         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2795             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2796                 STRLEN kid_label_len;
2797                 U32 kid_label_flags;
2798                 const char *kid_label = CopLABEL_len_flags(kCOP,
2799                                                     &kid_label_len, &kid_label_flags);
2800                 if (kid_label && (
2801                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2802                         (flags & SVf_UTF8)
2803                             ? (bytes_cmp_utf8(
2804                                         (const U8*)kid_label, kid_label_len,
2805                                         (const U8*)label, len) == 0)
2806                             : (bytes_cmp_utf8(
2807                                         (const U8*)label, len,
2808                                         (const U8*)kid_label, kid_label_len) == 0)
2809                     : ( len == kid_label_len && ((kid_label == label)
2810                                     || memEQ(kid_label, label, len)))))
2811                     return kid;
2812             }
2813         }
2814         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2815             if (kid == PL_lastgotoprobe)
2816                 continue;
2817             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2818                 if (ops == opstack)
2819                     *ops++ = kid;
2820                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2821                          ops[-1]->op_type == OP_DBSTATE)
2822                     ops[-1] = kid;
2823                 else
2824                     *ops++ = kid;
2825             }
2826             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2827                 return o;
2828         }
2829     }
2830     *ops = 0;
2831     return 0;
2832 }
2833
2834 PP(pp_goto)
2835 {
2836     dVAR; dSP;
2837     OP *retop = NULL;
2838     I32 ix;
2839     register PERL_CONTEXT *cx;
2840 #define GOTO_DEPTH 64
2841     OP *enterops[GOTO_DEPTH];
2842     const char *label = NULL;
2843     STRLEN label_len = 0;
2844     U32 label_flags = 0;
2845     const bool do_dump = (PL_op->op_type == OP_DUMP);
2846     static const char must_have_label[] = "goto must have label";
2847
2848     if (PL_op->op_flags & OPf_STACKED) {
2849         SV * const sv = POPs;
2850
2851         /* This egregious kludge implements goto &subroutine */
2852         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2853             I32 cxix;
2854             register PERL_CONTEXT *cx;
2855             CV *cv = MUTABLE_CV(SvRV(sv));
2856             SV** mark;
2857             I32 items = 0;
2858             I32 oldsave;
2859             bool reified = 0;
2860
2861         retry:
2862             if (!CvROOT(cv) && !CvXSUB(cv)) {
2863                 const GV * const gv = CvGV(cv);
2864                 if (gv) {
2865                     GV *autogv;
2866                     SV *tmpstr;
2867                     /* autoloaded stub? */
2868                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2869                         goto retry;
2870                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2871                                           GvNAMELEN(gv),
2872                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2873                     if (autogv && (cv = GvCV(autogv)))
2874                         goto retry;
2875                     tmpstr = sv_newmortal();
2876                     gv_efullname3(tmpstr, gv, NULL);
2877                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2878                 }
2879                 DIE(aTHX_ "Goto undefined subroutine");
2880             }
2881
2882             /* First do some returnish stuff. */
2883             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2884             FREETMPS;
2885             cxix = dopoptosub(cxstack_ix);
2886             if (cxix < 0)
2887                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2888             if (cxix < cxstack_ix)
2889                 dounwind(cxix);
2890             TOPBLOCK(cx);
2891             SPAGAIN;
2892             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2893             if (CxTYPE(cx) == CXt_EVAL) {
2894                 if (CxREALEVAL(cx))
2895                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2896                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2897                 else
2898                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2899                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2900             }
2901             else if (CxMULTICALL(cx))
2902                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2903             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2904                 /* put @_ back onto stack */
2905                 AV* av = cx->blk_sub.argarray;
2906
2907                 items = AvFILLp(av) + 1;
2908                 EXTEND(SP, items+1); /* @_ could have been extended. */
2909                 Copy(AvARRAY(av), SP + 1, items, SV*);
2910                 SvREFCNT_dec(GvAV(PL_defgv));
2911                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2912                 CLEAR_ARGARRAY(av);
2913                 /* abandon @_ if it got reified */
2914                 if (AvREAL(av)) {
2915                     reified = 1;
2916                     SvREFCNT_dec(av);
2917                     av = newAV();
2918                     av_extend(av, items-1);
2919                     AvREIFY_only(av);
2920                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2921                 }
2922             }
2923             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2924                 AV* const av = GvAV(PL_defgv);
2925                 items = AvFILLp(av) + 1;
2926                 EXTEND(SP, items+1); /* @_ could have been extended. */
2927                 Copy(AvARRAY(av), SP + 1, items, SV*);
2928             }
2929             mark = SP;
2930             SP += items;
2931             if (CxTYPE(cx) == CXt_SUB &&
2932                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2933                 SvREFCNT_dec(cx->blk_sub.cv);
2934             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2935             LEAVE_SCOPE(oldsave);
2936
2937             /* A destructor called during LEAVE_SCOPE could have undefined
2938              * our precious cv.  See bug #99850. */
2939             if (!CvROOT(cv) && !CvXSUB(cv)) {
2940                 const GV * const gv = CvGV(cv);
2941                 if (gv) {
2942                     SV * const tmpstr = sv_newmortal();
2943                     gv_efullname3(tmpstr, gv, NULL);
2944                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2945                                SVfARG(tmpstr));
2946                 }
2947                 DIE(aTHX_ "Goto undefined subroutine");
2948             }
2949
2950             /* Now do some callish stuff. */
2951             SAVETMPS;
2952             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2953             if (CvISXSUB(cv)) {
2954                 OP* const retop = cx->blk_sub.retop;
2955                 SV **newsp PERL_UNUSED_DECL;
2956                 I32 gimme PERL_UNUSED_DECL;
2957                 if (reified) {
2958                     I32 index;
2959                     for (index=0; index<items; index++)
2960                         sv_2mortal(SP[-index]);
2961                 }
2962
2963                 /* XS subs don't have a CxSUB, so pop it */
2964                 POPBLOCK(cx, PL_curpm);
2965                 /* Push a mark for the start of arglist */
2966                 PUSHMARK(mark);
2967                 PUTBACK;
2968                 (void)(*CvXSUB(cv))(aTHX_ cv);
2969                 LEAVE;
2970                 return retop;
2971             }
2972             else {
2973                 AV* const padlist = CvPADLIST(cv);
2974                 if (CxTYPE(cx) == CXt_EVAL) {
2975                     PL_in_eval = CxOLD_IN_EVAL(cx);
2976                     PL_eval_root = cx->blk_eval.old_eval_root;
2977                     cx->cx_type = CXt_SUB;
2978                 }
2979                 cx->blk_sub.cv = cv;
2980                 cx->blk_sub.olddepth = CvDEPTH(cv);
2981
2982                 CvDEPTH(cv)++;
2983                 if (CvDEPTH(cv) < 2)
2984                     SvREFCNT_inc_simple_void_NN(cv);
2985                 else {
2986                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2987                         sub_crush_depth(cv);
2988                     pad_push(padlist, CvDEPTH(cv));
2989                 }
2990                 PL_curcop = cx->blk_oldcop;
2991                 SAVECOMPPAD();
2992                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2993                 if (CxHASARGS(cx))
2994                 {
2995                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2996
2997                     cx->blk_sub.savearray = GvAV(PL_defgv);
2998                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2999                     CX_CURPAD_SAVE(cx->blk_sub);
3000                     cx->blk_sub.argarray = av;
3001
3002                     if (items >= AvMAX(av) + 1) {
3003                         SV **ary = AvALLOC(av);
3004                         if (AvARRAY(av) != ary) {
3005                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
3006                             AvARRAY(av) = ary;
3007                         }
3008                         if (items >= AvMAX(av) + 1) {
3009                             AvMAX(av) = items - 1;
3010                             Renew(ary,items+1,SV*);
3011                             AvALLOC(av) = ary;
3012                             AvARRAY(av) = ary;
3013                         }
3014                     }
3015                     ++mark;
3016                     Copy(mark,AvARRAY(av),items,SV*);
3017                     AvFILLp(av) = items - 1;
3018                     assert(!AvREAL(av));
3019                     if (reified) {
3020                         /* transfer 'ownership' of refcnts to new @_ */
3021                         AvREAL_on(av);
3022                         AvREIFY_off(av);
3023                     }
3024                     while (items--) {
3025                         if (*mark)
3026                             SvTEMP_off(*mark);
3027                         mark++;
3028                     }
3029                 }
3030                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
3031                     Perl_get_db_sub(aTHX_ NULL, cv);
3032                     if (PERLDB_GOTO) {
3033                         CV * const gotocv = get_cvs("DB::goto", 0);
3034                         if (gotocv) {
3035                             PUSHMARK( PL_stack_sp );
3036                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3037                             PL_stack_sp--;
3038                         }
3039                     }
3040                 }
3041                 RETURNOP(CvSTART(cv));
3042             }
3043         }
3044         else {
3045             label       = SvPV_const(sv, label_len);
3046             label_flags = SvUTF8(sv);
3047             if (!(do_dump || *label))
3048                 DIE(aTHX_ must_have_label);
3049         }
3050     }
3051     else if (PL_op->op_flags & OPf_SPECIAL) {
3052         if (! do_dump)
3053             DIE(aTHX_ must_have_label);
3054     }
3055     else {
3056         label       = cPVOP->op_pv;
3057         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3058         label_len   = strlen(label);
3059     }
3060
3061     PERL_ASYNC_CHECK();
3062
3063     if (label && *label) {
3064         OP *gotoprobe = NULL;
3065         bool leaving_eval = FALSE;
3066         bool in_block = FALSE;
3067         PERL_CONTEXT *last_eval_cx = NULL;
3068
3069         /* find label */
3070
3071         PL_lastgotoprobe = NULL;
3072         *enterops = 0;
3073         for (ix = cxstack_ix; ix >= 0; ix--) {
3074             cx = &cxstack[ix];
3075             switch (CxTYPE(cx)) {
3076             case CXt_EVAL:
3077                 leaving_eval = TRUE;
3078                 if (!CxTRYBLOCK(cx)) {
3079                     gotoprobe = (last_eval_cx ?
3080                                 last_eval_cx->blk_eval.old_eval_root :
3081                                 PL_eval_root);
3082                     last_eval_cx = cx;
3083                     break;
3084                 }
3085                 /* else fall through */
3086             case CXt_LOOP_LAZYIV:
3087             case CXt_LOOP_LAZYSV:
3088             case CXt_LOOP_FOR:
3089             case CXt_LOOP_PLAIN:
3090             case CXt_GIVEN:
3091             case CXt_WHEN:
3092                 gotoprobe = cx->blk_oldcop->op_sibling;
3093                 break;
3094             case CXt_SUBST:
3095                 continue;
3096             case CXt_BLOCK:
3097                 if (ix) {
3098                     gotoprobe = cx->blk_oldcop->op_sibling;
3099                     in_block = TRUE;
3100                 } else
3101                     gotoprobe = PL_main_root;
3102                 break;
3103             case CXt_SUB:
3104                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3105                     gotoprobe = CvROOT(cx->blk_sub.cv);
3106                     break;
3107                 }
3108                 /* FALL THROUGH */
3109             case CXt_FORMAT:
3110             case CXt_NULL:
3111                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3112             default:
3113                 if (ix)
3114                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3115                         CxTYPE(cx), (long) ix);
3116                 gotoprobe = PL_main_root;
3117                 break;
3118             }
3119             if (gotoprobe) {
3120                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3121                                     enterops, enterops + GOTO_DEPTH);
3122                 if (retop)
3123                     break;
3124                 if (gotoprobe->op_sibling &&
3125                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3126                         gotoprobe->op_sibling->op_sibling) {
3127                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3128                                         label, label_len, label_flags, enterops,
3129                                         enterops + GOTO_DEPTH);
3130                     if (retop)
3131                         break;
3132                 }
3133             }
3134             PL_lastgotoprobe = gotoprobe;
3135         }
3136         if (!retop)
3137             DIE(aTHX_ "Can't find label %"SVf,
3138                             SVfARG(newSVpvn_flags(label, label_len,
3139                                         SVs_TEMP | label_flags)));
3140
3141         /* if we're leaving an eval, check before we pop any frames
3142            that we're not going to punt, otherwise the error
3143            won't be caught */
3144
3145         if (leaving_eval && *enterops && enterops[1]) {
3146             I32 i;
3147             for (i = 1; enterops[i]; i++)
3148                 if (enterops[i]->op_type == OP_ENTERITER)
3149                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3150         }
3151
3152         if (*enterops && enterops[1]) {
3153             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3154             if (enterops[i])
3155                 deprecate("\"goto\" to jump into a construct");
3156         }
3157
3158         /* pop unwanted frames */
3159
3160         if (ix < cxstack_ix) {
3161             I32 oldsave;
3162
3163             if (ix < 0)
3164                 ix = 0;
3165             dounwind(ix);
3166             TOPBLOCK(cx);
3167             oldsave = PL_scopestack[PL_scopestack_ix];
3168             LEAVE_SCOPE(oldsave);
3169         }
3170
3171         /* push wanted frames */
3172
3173         if (*enterops && enterops[1]) {
3174             OP * const oldop = PL_op;
3175             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3176             for (; enterops[ix]; ix++) {
3177                 PL_op = enterops[ix];
3178                 /* Eventually we may want to stack the needed arguments
3179                  * for each op.  For now, we punt on the hard ones. */
3180                 if (PL_op->op_type == OP_ENTERITER)
3181                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3182                 PL_op->op_ppaddr(aTHX);
3183             }
3184             PL_op = oldop;
3185         }
3186     }
3187
3188     if (do_dump) {
3189 #ifdef VMS
3190         if (!retop) retop = PL_main_start;
3191 #endif
3192         PL_restartop = retop;
3193         PL_do_undump = TRUE;
3194
3195         my_unexec();
3196
3197         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3198         PL_do_undump = FALSE;
3199     }
3200
3201     RETURNOP(retop);
3202 }
3203
3204 PP(pp_exit)
3205 {
3206     dVAR;
3207     dSP;
3208     I32 anum;
3209
3210     if (MAXARG < 1)
3211         anum = 0;
3212     else if (!TOPs) {
3213         anum = 0; (void)POPs;
3214     }
3215     else {
3216         anum = SvIVx(POPs);
3217 #ifdef VMS
3218         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3219             anum = 0;
3220         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3221 #endif
3222     }
3223     PL_exit_flags |= PERL_EXIT_EXPECTED;
3224 #ifdef PERL_MAD
3225     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3226     if (anum || !(PL_minus_c && PL_madskills))
3227         my_exit(anum);
3228 #else
3229     my_exit(anum);
3230 #endif
3231     PUSHs(&PL_sv_undef);
3232     RETURN;
3233 }
3234
3235 /* Eval. */
3236
3237 STATIC void
3238 S_save_lines(pTHX_ AV *array, SV *sv)
3239 {
3240     const char *s = SvPVX_const(sv);
3241     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3242     I32 line = 1;
3243
3244     PERL_ARGS_ASSERT_SAVE_LINES;
3245
3246     while (s && s < send) {
3247         const char *t;
3248         SV * const tmpstr = newSV_type(SVt_PVMG);
3249
3250         t = (const char *)memchr(s, '\n', send - s);
3251         if (t)
3252             t++;
3253         else
3254             t = send;
3255
3256         sv_setpvn(tmpstr, s, t - s);
3257         av_store(array, line++, tmpstr);
3258         s = t;
3259     }
3260 }
3261
3262 /*
3263 =for apidoc docatch
3264
3265 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3266
3267 0 is used as continue inside eval,
3268
3269 3 is used for a die caught by an inner eval - continue inner loop
3270
3271 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3272 establish a local jmpenv to handle exception traps.
3273
3274 =cut
3275 */
3276 STATIC OP *
3277 S_docatch(pTHX_ OP *o)
3278 {
3279     dVAR;
3280     int ret;
3281     OP * const oldop = PL_op;
3282     dJMPENV;
3283
3284 #ifdef DEBUGGING
3285     assert(CATCH_GET == TRUE);
3286 #endif
3287     PL_op = o;
3288
3289     JMPENV_PUSH(ret);
3290     switch (ret) {
3291     case 0:
3292         assert(cxstack_ix >= 0);
3293         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3294         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3295  redo_body:
3296         CALLRUNOPS(aTHX);
3297         break;
3298     case 3:
3299         /* die caught by an inner eval - continue inner loop */
3300         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3301             PL_restartjmpenv = NULL;
3302             PL_op = PL_restartop;
3303             PL_restartop = 0;
3304             goto redo_body;
3305         }
3306         /* FALL THROUGH */
3307     default:
3308         JMPENV_POP;
3309         PL_op = oldop;
3310         JMPENV_JUMP(ret);
3311         /* NOTREACHED */
3312     }
3313     JMPENV_POP;
3314     PL_op = oldop;
3315     return NULL;
3316 }
3317
3318 /* James Bond: Do you expect me to talk?
3319    Auric Goldfinger: No, Mr. Bond. I expect you to die.
3320
3321    This code is an ugly hack, doesn't work with lexicals in subroutines that are
3322    called more than once, and is only used by regcomp.c, for (?{}) blocks.
3323
3324    Currently it is not used outside the core code. Best if it stays that way.
3325
3326    Hence it's now deprecated, and will be removed.
3327 */
3328 OP *
3329 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3330 /* sv Text to convert to OP tree. */
3331 /* startop op_free() this to undo. */
3332 /* code Short string id of the caller. */
3333 {
3334     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3335     return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3336 }
3337
3338 /* Don't use this. It will go away without warning once the regexp engine is
3339    refactored not to use it.  */
3340 OP *
3341 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3342                               PAD **padp)
3343 {
3344     dVAR; dSP;                          /* Make POPBLOCK work. */
3345     PERL_CONTEXT *cx;
3346     SV **newsp;
3347     I32 gimme = G_VOID;
3348     I32 optype;
3349     OP dummy;
3350     char tbuf[TYPE_DIGITS(long) + 12 + 10];
3351     char *tmpbuf = tbuf;
3352     char *safestr;
3353     int runtime;
3354     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3355     STRLEN len;
3356     bool need_catch;
3357
3358     PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3359
3360     ENTER_with_name("eval");
3361     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3362     SAVETMPS;
3363     /* switch to eval mode */
3364
3365     if (IN_PERL_COMPILETIME) {
3366         SAVECOPSTASH_FREE(&PL_compiling);
3367         CopSTASH_set(&PL_compiling, PL_curstash);
3368     }
3369     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3370         SV * const sv = sv_newmortal();
3371         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3372                        code, (unsigned long)++PL_evalseq,
3373                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3374         tmpbuf = SvPVX(sv);
3375         len = SvCUR(sv);
3376     }
3377     else
3378         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3379                           (unsigned long)++PL_evalseq);
3380     SAVECOPFILE_FREE(&PL_compiling);
3381     CopFILE_set(&PL_compiling, tmpbuf+2);
3382     SAVECOPLINE(&PL_compiling);
3383     CopLINE_set(&PL_compiling, 1);
3384     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3385        deleting the eval's FILEGV from the stash before gv_check() runs
3386        (i.e. before run-time proper). To work around the coredump that
3387        ensues, we always turn GvMULTI_on for any globals that were
3388        introduced within evals. See force_ident(). GSAR 96-10-12 */
3389     safestr = savepvn(tmpbuf, len);
3390     SAVEDELETE(PL_defstash, safestr, len);
3391     SAVEHINTS();
3392 #ifdef OP_IN_REGISTER
3393     PL_opsave = op;
3394 #else
3395     SAVEVPTR(PL_op);
3396 #endif
3397
3398     /* we get here either during compilation, or via pp_regcomp at runtime */
3399     runtime = IN_PERL_RUNTIME;
3400     if (runtime)
3401     {
3402         runcv = find_runcv(NULL);
3403
3404         /* At run time, we have to fetch the hints from PL_curcop. */
3405         PL_hints = PL_curcop->cop_hints;
3406         if (PL_hints & HINT_LOCALIZE_HH) {
3407             /* SAVEHINTS created a new HV in PL_hintgv, which we
3408                need to GC */
3409             SvREFCNT_dec(GvHV(PL_hintgv));
3410             GvHV(PL_hintgv) =
3411              refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3412             hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3413         }
3414         SAVECOMPILEWARNINGS();
3415         PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3416         cophh_free(CopHINTHASH_get(&PL_compiling));
3417         /* XXX Does this need to avoid copying a label? */
3418         PL_compiling.cop_hints_hash
3419          = cophh_copy(PL_curcop->cop_hints_hash);
3420     }
3421
3422     PL_op = &dummy;
3423     PL_op->op_type = OP_ENTEREVAL;
3424     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3425     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3426     PUSHEVAL(cx, 0);
3427     need_catch = CATCH_GET;
3428     CATCH_SET(TRUE);
3429
3430     if (runtime)
3431         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
3432     else
3433         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
3434     CATCH_SET(need_catch);
3435     POPBLOCK(cx,PL_curpm);
3436     POPEVAL(cx);
3437
3438     (*startop)->op_type = OP_NULL;
3439     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3440     /* XXX DAPM do this properly one year */
3441     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3442     LEAVE_with_name("eval");
3443     if (IN_PERL_COMPILETIME)
3444         CopHINTS_set(&PL_compiling, PL_hints);
3445 #ifdef OP_IN_REGISTER
3446     op = PL_opsave;
3447 #endif
3448     PERL_UNUSED_VAR(newsp);
3449     PERL_UNUSED_VAR(optype);
3450
3451     return PL_eval_start;
3452 }
3453
3454
3455 /*
3456 =for apidoc find_runcv
3457
3458 Locate the CV corresponding to the currently executing sub or eval.
3459 If db_seqp is non_null, skip CVs that are in the DB package and populate
3460 *db_seqp with the cop sequence number at the point that the DB:: code was
3461 entered. (allows debuggers to eval in the scope of the breakpoint rather
3462 than in the scope of the debugger itself).
3463
3464 =cut
3465 */
3466
3467 CV*
3468 Perl_find_runcv(pTHX_ U32 *db_seqp)
3469 {
3470     dVAR;
3471     PERL_SI      *si;
3472
3473     if (db_seqp)
3474         *db_seqp = PL_curcop->cop_seq;
3475     for (si = PL_curstackinfo; si; si = si->si_prev) {
3476         I32 ix;
3477         for (ix = si->si_cxix; ix >= 0; ix--) {
3478             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3479             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3480                 CV * const cv = cx->blk_sub.cv;
3481                 /* skip DB:: code */
3482                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3483                     *db_seqp = cx->blk_oldcop->cop_seq;
3484                     continue;
3485                 }
3486                 return cv;
3487             }
3488             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3489                 return cx->blk_eval.cv;
3490         }
3491     }
3492     return PL_main_cv;
3493 }
3494
3495
3496 /* Run yyparse() in a setjmp wrapper. Returns:
3497  *   0: yyparse() successful
3498  *   1: yyparse() failed
3499  *   3: yyparse() died
3500  */
3501 STATIC int
3502 S_try_yyparse(pTHX_ int gramtype)
3503 {
3504     int ret;
3505     dJMPENV;
3506
3507     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3508     JMPENV_PUSH(ret);
3509     switch (ret) {
3510     case 0:
3511         ret = yyparse(gramtype) ? 1 : 0;
3512         break;
3513     case 3:
3514         break;
3515     default:
3516         JMPENV_POP;
3517         JMPENV_JUMP(ret);
3518         /* NOTREACHED */
3519     }
3520     JMPENV_POP;
3521     return ret;
3522 }
3523
3524
3525 /* Compile a require/do, an eval '', or a /(?{...})/.
3526  * In the last case, startop is non-null, and contains the address of
3527  * a pointer that should be set to the just-compiled code.
3528  * outside is the lexically enclosing CV (if any) that invoked us.
3529  * Returns a bool indicating whether the compile was successful; if so,
3530  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3531  * pushes undef (also croaks if startop != NULL).
3532  */
3533
3534 /* This function is called from three places, sv_compile_2op, pp_require
3535  * and pp_entereval.  These can be distinguished as follows:
3536  *    sv_compile_2op - startop is non-null
3537  *    pp_require     - startop is null; saveop is not entereval
3538  *    pp_entereval   - startop is null; saveop is entereval
3539  */
3540
3541 STATIC bool
3542 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
3543 {
3544     dVAR; dSP;
3545     OP * const saveop = PL_op;
3546     COP * const oldcurcop = PL_curcop;
3547     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3548     int yystatus;
3549     CV *evalcv;
3550
3551     PL_in_eval = (in_require
3552                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3553                   : EVAL_INEVAL);
3554
3555     PUSHMARK(SP);
3556
3557     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3558     CvEVAL_on(evalcv);
3559     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3560     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3561     cxstack[cxstack_ix].blk_gimme = gimme;
3562
3563     CvOUTSIDE_SEQ(evalcv) = seq;
3564     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3565
3566     /* set up a scratch pad */
3567
3568     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3569     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3570
3571
3572     if (!PL_madskills)
3573         SAVEMORTALIZESV(evalcv);        /* must remain until end of current statement */
3574
3575     /* make sure we compile in the right package */
3576
3577     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3578         SAVEGENERICSV(PL_curstash);
3579         PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3580     }
3581     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3582     SAVESPTR(PL_beginav);
3583     PL_beginav = newAV();
3584     SAVEFREESV(PL_beginav);
3585     SAVESPTR(PL_unitcheckav);
3586     PL_unitcheckav = newAV();
3587     SAVEFREESV(PL_unitcheckav);
3588
3589 #ifdef PERL_MAD
3590     SAVEBOOL(PL_madskills);
3591     PL_madskills = 0;
3592 #endif
3593
3594     if (!startop) ENTER_with_name("evalcomp");
3595     SAVESPTR(PL_compcv);
3596     PL_compcv = evalcv;
3597
3598     /* try to compile it */
3599
3600     PL_eval_root = NULL;
3601     PL_curcop = &PL_compiling;
3602     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3603         PL_in_eval |= EVAL_KEEPERR;
3604     else
3605         CLEAR_ERRSV();
3606
3607     if (!startop) {
3608         bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3609         SAVEHINTS();
3610         if (clear_hints) {
3611             PL_hints = 0;
3612             hv_clear(GvHV(PL_hintgv));
3613         }
3614         else {
3615             PL_hints = saveop->op_private & OPpEVAL_COPHH
3616                          ? oldcurcop->cop_hints : saveop->op_targ;
3617             if (hh) {
3618                 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3619                 SvREFCNT_dec(GvHV(PL_hintgv));
3620                 GvHV(PL_hintgv) = hh;
3621             }
3622         }
3623         SAVECOMPILEWARNINGS();
3624         if (clear_hints) {
3625             if (PL_dowarn & G_WARN_ALL_ON)
3626                 PL_compiling.cop_warnings = pWARN_ALL ;
3627             else if (PL_dowarn & G_WARN_ALL_OFF)
3628                 PL_compiling.cop_warnings = pWARN_NONE ;
3629             else
3630                 PL_compiling.cop_warnings = pWARN_STD ;
3631         }
3632         else {
3633             PL_compiling.cop_warnings =
3634                 DUP_WARNINGS(oldcurcop->cop_warnings);
3635             cophh_free(CopHINTHASH_get(&PL_compiling));
3636             if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3637                 /* The label, if present, is the first entry on the chain. So rather
3638                    than writing a blank label in front of it (which involves an
3639                    allocation), just use the next entry in the chain.  */
3640                 PL_compiling.cop_hints_hash
3641                     = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3642                 /* Check the assumption that this removed the label.  */
3643                 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3644             }
3645             else
3646                 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3647         }
3648     }
3649
3650     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3651
3652     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3653      * so honour CATCH_GET and trap it here if necessary */
3654
3655     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3656
3657     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3658         SV **newsp;                     /* Used by POPBLOCK. */
3659         PERL_CONTEXT *cx;
3660         I32 optype;                     /* Used by POPEVAL. */
3661         SV *namesv;
3662
3663         cx = NULL;
3664         namesv = NULL;
3665         PERL_UNUSED_VAR(newsp);
3666         PERL_UNUSED_VAR(optype);
3667
3668         /* note that if yystatus == 3, then the EVAL CX block has already
3669          * been popped, and various vars restored */
3670         PL_op = saveop;
3671         if (yystatus != 3) {
3672             if (PL_eval_root) {
3673                 op_free(PL_eval_root);
3674                 PL_eval_root = NULL;
3675             }
3676             SP = PL_stack_base + POPMARK;       /* pop original mark */
3677             if (!startop) {
3678                 POPBLOCK(cx,PL_curpm);
3679                 POPEVAL(cx);
3680                 namesv = cx->blk_eval.old_namesv;
3681             }
3682             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3683             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3684         }
3685
3686         if (in_require) {
3687             if (!cx) {
3688                 /* If cx is still NULL, it means that we didn't go in the
3689                  * POPEVAL branch. */
3690                 cx = &cxstack[cxstack_ix];
3691                 assert(CxTYPE(cx) == CXt_EVAL);
3692                 namesv = cx->blk_eval.old_namesv;
3693             }
3694             (void)hv_store(GvHVn(PL_incgv),
3695                            SvPVX_const(namesv),
3696                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3697                            &PL_sv_undef, 0);
3698             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3699                        SVfARG(ERRSV
3700                                 ? ERRSV
3701                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3702         }
3703         else if (startop) {
3704             if (yystatus != 3) {
3705                 POPBLOCK(cx,PL_curpm);
3706                 POPEVAL(cx);
3707             }
3708             Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3709                        SVfARG(ERRSV
3710                                 ? ERRSV
3711                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3712         }
3713         else {
3714             if (!*(SvPVx_nolen_const(ERRSV))) {
3715                 sv_setpvs(ERRSV, "Compilation error");
3716             }
3717         }
3718         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3719         PUTBACK;
3720         return FALSE;
3721     }
3722     else if (!startop) LEAVE_with_name("evalcomp");
3723     CopLINE_set(&PL_compiling, 0);
3724     if (startop) {
3725         *startop = PL_eval_root;
3726     } else
3727         SAVEFREEOP(PL_eval_root);
3728
3729     DEBUG_x(dump_eval());
3730
3731     /* Register with debugger: */
3732     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3733         CV * const cv = get_cvs("DB::postponed", 0);
3734         if (cv) {
3735             dSP;
3736             PUSHMARK(SP);
3737             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3738             PUTBACK;
3739             call_sv(MUTABLE_SV(cv), G_DISCARD);
3740         }
3741     }
3742
3743     if (PL_unitcheckav) {
3744         OP *es = PL_eval_start;
3745         call_list(PL_scopestack_ix, PL_unitcheckav);
3746         PL_eval_start = es;
3747     }
3748
3749     /* compiled okay, so do it */
3750
3751     CvDEPTH(evalcv) = 1;
3752     SP = PL_stack_base + POPMARK;               /* pop original mark */
3753     PL_op = saveop;                     /* The caller may need it. */
3754     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3755
3756     PUTBACK;
3757     return TRUE;
3758 }
3759
3760 STATIC PerlIO *
3761 S_check_type_and_open(pTHX_ SV *name)
3762 {
3763     Stat_t st;
3764     const char *p = SvPV_nolen_const(name);
3765     const int st_rc = PerlLIO_stat(p, &st);
3766
3767     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3768
3769     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3770         return NULL;
3771     }
3772
3773 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3774     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3775 #else
3776     return PerlIO_open(p, PERL_SCRIPT_MODE);
3777 #endif
3778 }
3779
3780 #ifndef PERL_DISABLE_PMC
3781 STATIC PerlIO *
3782 S_doopen_pm(pTHX_ SV *name)
3783 {
3784     STRLEN namelen;
3785     const char *p = SvPV_const(name, namelen);
3786
3787     PERL_ARGS_ASSERT_DOOPEN_PM;
3788
3789     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3790         SV *const pmcsv = sv_newmortal();
3791         Stat_t pmcstat;
3792
3793         SvSetSV_nosteal(pmcsv,name);
3794         sv_catpvn(pmcsv, "c", 1);
3795
3796         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3797             return check_type_and_open(pmcsv);
3798     }
3799     return check_type_and_open(name);
3800 }
3801 #else
3802 #  define doopen_pm(name) check_type_and_open(name)
3803 #endif /* !PERL_DISABLE_PMC */
3804
3805 PP(pp_require)
3806 {
3807     dVAR; dSP;
3808     register PERL_CONTEXT *cx;
3809     SV *sv;
3810     const char *name;
3811     STRLEN len;
3812     char * unixname;
3813     STRLEN unixlen;
3814 #ifdef VMS
3815     int vms_unixname = 0;
3816 #endif
3817     const char *tryname = NULL;
3818     SV *namesv = NULL;
3819     const I32 gimme = GIMME_V;
3820     int filter_has_file = 0;
3821     PerlIO *tryrsfp = NULL;
3822     SV *filter_cache = NULL;
3823     SV *filter_state = NULL;
3824     SV *filter_sub = NULL;
3825     SV *hook_sv = NULL;
3826     SV *encoding;
3827     OP *op;
3828
3829     sv = POPs;
3830     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3831         sv = sv_2mortal(new_version(sv));
3832         if (!sv_derived_from(PL_patchlevel, "version"))
3833             upg_version(PL_patchlevel, TRUE);
3834         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3835             if ( vcmp(sv,PL_patchlevel) <= 0 )
3836                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3837                     SVfARG(sv_2mortal(vnormal(sv))),
3838                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3839                 );
3840         }
3841         else {
3842             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3843                 I32 first = 0;
3844                 AV *lav;
3845                 SV * const req = SvRV(sv);
3846                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3847
3848                 /* get the left hand term */
3849                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3850
3851                 first  = SvIV(*av_fetch(lav,0,0));
3852                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3853                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3854                     || av_len(lav) > 1               /* FP with > 3 digits */
3855                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3856                    ) {
3857                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3858                         "%"SVf", stopped",
3859                         SVfARG(sv_2mortal(vnormal(req))),
3860                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3861                     );
3862                 }
3863                 else { /* probably 'use 5.10' or 'use 5.8' */
3864                     SV *hintsv;
3865                     I32 second = 0;
3866
3867                     if (av_len(lav)>=1)
3868                         second = SvIV(*av_fetch(lav,1,0));
3869
3870                     second /= second >= 600  ? 100 : 10;
3871                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3872                                            (int)first, (int)second);
3873                     upg_version(hintsv, TRUE);
3874
3875                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3876                         "--this is only %"SVf", stopped",
3877                         SVfARG(sv_2mortal(vnormal(req))),
3878                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3879                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3880                     );
3881                 }
3882             }
3883         }
3884
3885         RETPUSHYES;
3886     }
3887     name = SvPV_const(sv, len);
3888     if (!(name && len > 0 && *name))
3889         DIE(aTHX_ "Null filename used");
3890     TAINT_PROPER("require");
3891
3892
3893 #ifdef VMS
3894     /* The key in the %ENV hash is in the syntax of file passed as the argument
3895      * usually this is in UNIX format, but sometimes in VMS format, which
3896      * can result in a module being pulled in more than once.
3897      * To prevent this, the key must be stored in UNIX format if the VMS
3898      * name can be translated to UNIX.
3899      */
3900     if ((unixname = tounixspec(name, NULL)) != NULL) {
3901         unixlen = strlen(unixname);
3902         vms_unixname = 1;
3903     }
3904     else
3905 #endif
3906     {
3907         /* if not VMS or VMS name can not be translated to UNIX, pass it
3908          * through.
3909          */
3910         unixname = (char *) name;
3911         unixlen = len;
3912     }
3913     if (PL_op->op_type == OP_REQUIRE) {
3914         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3915                                           unixname, unixlen, 0);
3916         if ( svp ) {
3917             if (*svp != &PL_sv_undef)
3918                 RETPUSHYES;
3919             else
3920                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3921                             "Compilation failed in require", unixname);
3922         }
3923     }
3924
3925     /* prepare to compile file */
3926
3927     if (path_is_absolute(name)) {
3928         /* At this point, name is SvPVX(sv)  */
3929         tryname = name;
3930         tryrsfp = doopen_pm(sv);
3931     }
3932     if (!tryrsfp) {
3933         AV * const ar = GvAVn(PL_incgv);
3934         I32 i;
3935 #ifdef VMS
3936         if (vms_unixname)
3937 #endif
3938         {
3939             namesv = newSV_type(SVt_PV);
3940             for (i = 0; i <= AvFILL(ar); i++) {
3941                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3942
3943                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3944                     mg_get(dirsv);
3945                 if (SvROK(dirsv)) {
3946                     int count;
3947                     SV **svp;
3948                     SV *loader = dirsv;
3949
3950                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3951                         && !sv_isobject(loader))
3952                     {
3953                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3954                     }
3955
3956                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3957                                    PTR2UV(SvRV(dirsv)), name);
3958                     tryname = SvPVX_const(namesv);
3959                     tryrsfp = NULL;
3960
3961                     ENTER_with_name("call_INC");
3962                     SAVETMPS;
3963                     EXTEND(SP, 2);
3964
3965                     PUSHMARK(SP);
3966                     PUSHs(dirsv);
3967                     PUSHs(sv);
3968                     PUTBACK;
3969                     if (sv_isobject(loader))
3970                         count = call_method("INC", G_ARRAY);
3971                     else
3972                         count = call_sv(loader, G_ARRAY);
3973                     SPAGAIN;
3974
3975                     if (count > 0) {
3976                         int i = 0;
3977                         SV *arg;
3978
3979                         SP -= count - 1;
3980                         arg = SP[i++];
3981
3982                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3983                             && !isGV_with_GP(SvRV(arg))) {
3984                             filter_cache = SvRV(arg);
3985                             SvREFCNT_inc_simple_void_NN(filter_cache);
3986
3987                             if (i < count) {
3988                                 arg = SP[i++];
3989                             }
3990                         }
3991
3992                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3993                             arg = SvRV(arg);
3994                         }
3995
3996                         if (isGV_with_GP(arg)) {
3997                             IO * const io = GvIO((const GV *)arg);
3998
3999                             ++filter_has_file;
4000
4001                             if (io) {
4002                                 tryrsfp = IoIFP(io);
4003                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4004                                     PerlIO_close(IoOFP(io));
4005                                 }
4006                                 IoIFP(io) = NULL;
4007                                 IoOFP(io) = NULL;
4008                             }
4009
4010                             if (i < count) {
4011                                 arg = SP[i++];
4012                             }
4013                         }
4014
4015                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4016                             filter_sub = arg;
4017                             SvREFCNT_inc_simple_void_NN(filter_sub);
4018
4019                             if (i < count) {
4020                                 filter_state = SP[i];
4021                                 SvREFCNT_inc_simple_void(filter_state);
4022                             }
4023                         }
4024
4025                         if (!tryrsfp && (filter_cache || filter_sub)) {
4026                             tryrsfp = PerlIO_open(BIT_BUCKET,
4027                                                   PERL_SCRIPT_MODE);
4028                         }
4029                         SP--;
4030                     }
4031
4032                     PUTBACK;
4033                     FREETMPS;
4034                     LEAVE_with_name("call_INC");
4035
4036                     /* Adjust file name if the hook has set an %INC entry.
4037                        This needs to happen after the FREETMPS above.  */
4038                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4039                     if (svp)
4040                         tryname = SvPV_nolen_const(*svp);
4041
4042                     if (tryrsfp) {
4043                         hook_sv = dirsv;
4044                         break;
4045                     }
4046
4047                     filter_has_file = 0;
4048                     if (filter_cache) {
4049                         SvREFCNT_dec(filter_cache);
4050                         filter_cache = NULL;
4051                     }
4052                     if (filter_state) {
4053                         SvREFCNT_dec(filter_state);
4054                         filter_state = NULL;
4055                     }
4056                     if (filter_sub) {
4057                         SvREFCNT_dec(filter_sub);
4058                         filter_sub = NULL;
4059                     }
4060                 }
4061                 else {
4062                   if (!path_is_absolute(name)
4063                   ) {
4064                     const char *dir;
4065                     STRLEN dirlen;
4066
4067                     if (SvOK(dirsv)) {
4068                         dir = SvPV_const(dirsv, dirlen);
4069                     } else {
4070                         dir = "";
4071                         dirlen = 0;
4072                     }
4073
4074 #ifdef VMS
4075                     char *unixdir;
4076                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
4077                         continue;
4078                     sv_setpv(namesv, unixdir);
4079                     sv_catpv(namesv, unixname);
4080 #else
4081 #  ifdef __SYMBIAN32__
4082                     if (PL_origfilename[0] &&
4083                         PL_origfilename[1] == ':' &&
4084                         !(dir[0] && dir[1] == ':'))
4085                         Perl_sv_setpvf(aTHX_ namesv,
4086                                        "%c:%s\\%s",
4087                                        PL_origfilename[0],
4088                                        dir, name);
4089                     else
4090                         Perl_sv_setpvf(aTHX_ namesv,
4091                                        "%s\\%s",
4092                                        dir, name);
4093 #  else
4094                     /* The equivalent of
4095                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4096                        but without the need to parse the format string, or
4097                        call strlen on either pointer, and with the correct
4098                        allocation up front.  */
4099                     {
4100                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4101
4102                         memcpy(tmp, dir, dirlen);
4103                         tmp +=dirlen;
4104                         *tmp++ = '/';
4105                         /* name came from an SV, so it will have a '\0' at the
4106                            end that we can copy as part of this memcpy().  */
4107                         memcpy(tmp, name, len + 1);
4108
4109                         SvCUR_set(namesv, dirlen + len + 1);
4110                         SvPOK_on(namesv);
4111                     }
4112 #  endif
4113 #endif
4114                     TAINT_PROPER("require");
4115                     tryname = SvPVX_const(namesv);
4116                     tryrsfp = doopen_pm(namesv);
4117                     if (tryrsfp) {
4118                         if (tryname[0] == '.' && tryname[1] == '/') {
4119                             ++tryname;
4120                             while (*++tryname == '/');
4121                         }
4122                         break;
4123                     }
4124                     else if (errno == EMFILE)
4125                         /* no point in trying other paths if out of handles */
4126                         break;
4127                   }
4128                 }
4129             }
4130         }
4131     }
4132     sv_2mortal(namesv);
4133     if (!tryrsfp) {
4134         if (PL_op->op_type == OP_REQUIRE) {
4135             if(errno == EMFILE) {
4136                 /* diag_listed_as: Can't locate %s */
4137                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
4138             } else {
4139                 if (namesv) {                   /* did we lookup @INC? */
4140                     AV * const ar = GvAVn(PL_incgv);
4141                     I32 i;
4142                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4143                     for (i = 0; i <= AvFILL(ar); i++) {
4144                         sv_catpvs(inc, " ");
4145                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4146                     }
4147
4148                     /* diag_listed_as: Can't locate %s */
4149                     DIE(aTHX_
4150                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4151                         name,
4152                         (memEQ(name + len - 2, ".h", 3)
4153                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4154                         (memEQ(name + len - 3, ".ph", 4)
4155                          ? " (did you run h2ph?)" : ""),
4156                         inc
4157                         );
4158                 }
4159             }
4160             DIE(aTHX_ "Can't locate %s", name);
4161         }
4162
4163         RETPUSHUNDEF;
4164     }
4165     else
4166         SETERRNO(0, SS_NORMAL);
4167
4168     /* Assume success here to prevent recursive requirement. */
4169     /* name is never assigned to again, so len is still strlen(name)  */
4170     /* Check whether a hook in @INC has already filled %INC */
4171     if (!hook_sv) {
4172         (void)hv_store(GvHVn(PL_incgv),
4173                        unixname, unixlen, newSVpv(tryname,0),0);
4174     } else {
4175         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4176         if (!svp)
4177             (void)hv_store(GvHVn(PL_incgv),
4178                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4179     }
4180
4181     ENTER_with_name("eval");
4182     SAVETMPS;
4183     SAVECOPFILE_FREE(&PL_compiling);
4184     CopFILE_set(&PL_compiling, tryname);
4185     lex_start(NULL, tryrsfp, 0);
4186
4187     if (filter_sub || filter_cache) {
4188         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4189            than hanging another SV from it. In turn, filter_add() optionally
4190            takes the SV to use as the filter (or creates a new SV if passed
4191            NULL), so simply pass in whatever value filter_cache has.  */
4192         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4193         IoLINES(datasv) = filter_has_file;
4194         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4195         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4196     }
4197
4198     /* switch to eval mode */
4199     PUSHBLOCK(cx, CXt_EVAL, SP);
4200     PUSHEVAL(cx, name);
4201     cx->blk_eval.retop = PL_op->op_next;
4202
4203     SAVECOPLINE(&PL_compiling);
4204     CopLINE_set(&PL_compiling, 0);
4205
4206     PUTBACK;
4207
4208     /* Store and reset encoding. */
4209     encoding = PL_encoding;
4210     PL_encoding = NULL;
4211
4212     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
4213         op = DOCATCH(PL_eval_start);
4214     else
4215         op = PL_op->op_next;
4216
4217     /* Restore encoding. */
4218     PL_encoding = encoding;
4219
4220     return op;
4221 }
4222
4223 /* This is a op added to hold the hints hash for
4224    pp_entereval. The hash can be modified by the code
4225    being eval'ed, so we return a copy instead. */
4226
4227 PP(pp_hintseval)
4228 {
4229     dVAR;
4230     dSP;
4231     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4232     RETURN;
4233 }
4234
4235
4236 PP(pp_entereval)
4237 {
4238     dVAR; dSP;
4239     register PERL_CONTEXT *cx;
4240     SV *sv;
4241     const I32 gimme = GIMME_V;
4242     const U32 was = PL_breakable_sub_gen;
4243     char tbuf[TYPE_DIGITS(long) + 12];
4244     bool saved_delete = FALSE;
4245     char *tmpbuf = tbuf;
4246     STRLEN len;
4247     CV* runcv;
4248     U32 seq, lex_flags = 0;
4249     HV *saved_hh = NULL;
4250     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4251
4252     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4253         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4254     }
4255     else if (PL_hints & HINT_LOCALIZE_HH || (
4256                 PL_op->op_private & OPpEVAL_COPHH
4257              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4258             )) {
4259         saved_hh = cop_hints_2hv(PL_curcop, 0);
4260         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4261     }
4262     sv = POPs;
4263     if (!SvPOK(sv)) {
4264         /* make sure we've got a plain PV (no overload etc) before testing
4265          * for taint. Making a copy here is probably overkill, but better
4266          * safe than sorry */
4267         STRLEN len;
4268         const char * const p = SvPV_const(sv, len);
4269
4270         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4271         lex_flags |= LEX_START_COPIED;
4272
4273         if (bytes && SvUTF8(sv))
4274             SvPVbyte_force(sv, len);
4275     }
4276     else if (bytes && SvUTF8(sv)) {
4277         /* Don't modify someone else's scalar */
4278         STRLEN len;
4279         sv = newSVsv(sv);
4280         (void)sv_2mortal(sv);
4281         SvPVbyte_force(sv,len);
4282         lex_flags |= LEX_START_COPIED;
4283     }
4284
4285     TAINT_IF(SvTAINTED(sv));
4286     TAINT_PROPER("eval");
4287
4288     ENTER_with_name("eval");
4289     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4290                            ? LEX_IGNORE_UTF8_HINTS
4291                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4292                         )
4293              );
4294     SAVETMPS;
4295
4296     /* switch to eval mode */
4297
4298     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4299         SV * const temp_sv = sv_newmortal();
4300         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4301                        (unsigned long)++PL_evalseq,
4302                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4303         tmpbuf = SvPVX(temp_sv);
4304         len = SvCUR(temp_sv);
4305     }
4306     else
4307         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4308     SAVECOPFILE_FREE(&PL_compiling);
4309     CopFILE_set(&PL_compiling, tmpbuf+2);
4310     SAVECOPLINE(&PL_compiling);
4311     CopLINE_set(&PL_compiling, 1);
4312     /* special case: an eval '' executed within the DB package gets lexically
4313      * placed in the first non-DB CV rather than the current CV - this
4314      * allows the debugger to execute code, find lexicals etc, in the
4315      * scope of the code being debugged. Passing &seq gets find_runcv
4316      * to do the dirty work for us */
4317     runcv = find_runcv(&seq);
4318
4319     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4320     PUSHEVAL(cx, 0);
4321     cx->blk_eval.retop = PL_op->op_next;
4322
4323     /* prepare to compile string */
4324
4325     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4326         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4327     else {
4328         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4329            deleting the eval's FILEGV from the stash before gv_check() runs
4330            (i.e. before run-time proper). To work around the coredump that
4331            ensues, we always turn GvMULTI_on for any globals that were
4332            introduced within evals. See force_ident(). GSAR 96-10-12 */
4333         char *const safestr = savepvn(tmpbuf, len);
4334         SAVEDELETE(PL_defstash, safestr, len);
4335         saved_delete = TRUE;
4336     }
4337
4338     PUTBACK;
4339
4340     if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
4341         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4342             ? (PERLDB_LINE || PERLDB_SAVESRC)
4343             :  PERLDB_SAVESRC_NOSUBS) {
4344             /* Retain the filegv we created.  */
4345         } else if (!saved_delete) {
4346             char *const safestr = savepvn(tmpbuf, len);
4347             SAVEDELETE(PL_defstash, safestr, len);
4348         }
4349         return DOCATCH(PL_eval_start);
4350     } else {
4351         /* We have already left the scope set up earlier thanks to the LEAVE
4352            in doeval().  */
4353         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4354             ? (PERLDB_LINE || PERLDB_SAVESRC)
4355             :  PERLDB_SAVESRC_INVALID) {
4356             /* Retain the filegv we created.  */
4357         } else if (!saved_delete) {
4358             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4359         }
4360         return PL_op->op_next;
4361     }
4362 }
4363
4364 PP(pp_leaveeval)
4365 {
4366     dVAR; dSP;
4367     SV **newsp;
4368     PMOP *newpm;
4369     I32 gimme;
4370     register PERL_CONTEXT *cx;
4371     OP *retop;
4372     const U8 save_flags = PL_op -> op_flags;
4373     I32 optype;
4374     SV *namesv;
4375     CV *evalcv;
4376
4377     PERL_ASYNC_CHECK();
4378     POPBLOCK(cx,newpm);
4379     POPEVAL(cx);
4380     namesv = cx->blk_eval.old_namesv;
4381     retop = cx->blk_eval.retop;
4382     evalcv = cx->blk_eval.cv;
4383
4384     TAINT_NOT;
4385     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4386                                 gimme, SVs_TEMP);
4387     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4388
4389 #ifdef DEBUGGING
4390     assert(CvDEPTH(evalcv) == 1);
4391 #endif
4392     CvDEPTH(evalcv) = 0;
4393
4394     if (optype == OP_REQUIRE &&
4395         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4396     {
4397         /* Unassume the success we assumed earlier. */
4398         (void)hv_delete(GvHVn(PL_incgv),
4399                         SvPVX_const(namesv),
4400                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4401                         G_DISCARD);
4402         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4403                                SVfARG(namesv));
4404         /* die_unwind() did LEAVE, or we won't be here */
4405     }
4406     else {
4407         LEAVE_with_name("eval");
4408         if (!(save_flags & OPf_SPECIAL)) {
4409             CLEAR_ERRSV();
4410         }
4411     }
4412
4413     RETURNOP(retop);
4414 }
4415
4416 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4417    close to the related Perl_create_eval_scope.  */
4418 void
4419 Perl_delete_eval_scope(pTHX)
4420 {
4421     SV **newsp;
4422     PMOP *newpm;
4423     I32 gimme;
4424     register PERL_CONTEXT *cx;
4425     I32 optype;
4426
4427     POPBLOCK(cx,newpm);
4428     POPEVAL(cx);
4429     PL_curpm = newpm;
4430     LEAVE_with_name("eval_scope");
4431     PERL_UNUSED_VAR(newsp);
4432     PERL_UNUSED_VAR(gimme);
4433     PERL_UNUSED_VAR(optype);
4434 }
4435
4436 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4437    also needed by Perl_fold_constants.  */
4438 PERL_CONTEXT *
4439 Perl_create_eval_scope(pTHX_ U32 flags)