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     TAINT_NOT;
  73     return NORMAL;
  74 }
  75
  76 PP(pp_regcomp)
  77 {
  78     dVAR;
  79     dSP;
  80     PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     SV **args;
  82     int nargs;
  83     REGEXP *re = NULL;
  84     REGEXP *new_re;
  85     const regexp_engine *eng;
  86     bool is_bare_re= FALSE;
  87
  88     if (PL_op->op_flags & OPf_STACKED) {
  89         dMARK;
  90         nargs = SP - MARK;
  91         args  = ++MARK;
  92     }
  93     else {
  94         nargs = 1;
  95         args  = SP;
  96     }
  97
  98     /* prevent recompiling under /o and ithreads. */
  99 #if defined(USE_ITHREADS)
 100     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
 101         SP = args-1;
 102         RETURN;
 103     }
 104 #endif
 105
 106     re = PM_GETRE(pm);
 107     assert (re != (REGEXP*) &PL_sv_undef);
 108     eng = re ? RX_ENGINE(re) : current_re_engine();
 109
 110     /*
 111      In the below logic: these are basically the same - check if this regcomp is part of a split.
 112
 113     (PL_op->op_pmflags & PMf_split )
 114     (PL_op->op_next->op_type == OP_PUSHRE)
 115
 116     We could add a new mask for this and copy the PMf_split, if we did
 117     some bit definition fiddling first.
 118
 119     For now we leave this
 120     */
 121
 122     new_re = (eng->op_comp
 123                     ? eng->op_comp
 124                     : &Perl_re_op_compile
 125             )(aTHX_ args, nargs, pm->op_code_list, eng, re,
 126                 &is_bare_re,
 127                 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
 128                 pm->op_pmflags |
 129                     (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
 130
 131     if (pm->op_pmflags & PMf_HAS_CV)
 132         ReANY(new_re)->qr_anoncv
 133                         = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
 134
 135     if (is_bare_re) {
 136         REGEXP *tmp;
 137         /* The match's LHS's get-magic might need to access this op's regexp
 138            (e.g. $' =~ /$re/ while foo; see bug 70764).  So we must call
 139            get-magic now before we replace the regexp. Hopefully this hack can
 140            be replaced with the approach described at
 141            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
 142            some day. */
 143         if (pm->op_type == OP_MATCH) {
 144             SV *lhs;
 145             const bool was_tainted = TAINT_get;
 146             if (pm->op_flags & OPf_STACKED)
 147                 lhs = args[-1];
 148             else if (pm->op_private & OPpTARGET_MY)
 149                 lhs = PAD_SV(pm->op_targ);
 150             else lhs = DEFSV;
 151             SvGETMAGIC(lhs);
 152             /* Restore the previous value of PL_tainted (which may have been
 153                modified by get-magic), to avoid incorrectly setting the
 154                RXf_TAINTED flag with RX_TAINT_on further down. */
 155             TAINT_set(was_tainted);
 156 #ifdef NO_TAINT_SUPPORT
 157             PERL_UNUSED_VAR(was_tainted);
 158 #endif
 159         }
 160         tmp = reg_temp_copy(NULL, new_re);
 161         ReREFCNT_dec(new_re);
 162         new_re = tmp;
 163     }
 164
 165     if (re != new_re) {
 166         ReREFCNT_dec(re);
 167         PM_SETRE(pm, new_re);
 168     }
 169
 170
 171     if (TAINTING_get && TAINT_get) {
 172         SvTAINTED_on((SV*)new_re);
 173         RX_TAINT_on(new_re);
 174     }
 175
 176 #if !defined(USE_ITHREADS)
 177     /* can't change the optree at runtime either */
 178     /* PMf_KEEP is handled differently under threads to avoid these problems */
 179     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
 180         pm = PL_curpm;
 181     if (pm->op_pmflags & PMf_KEEP) {
 182         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 183         cLOGOP->op_first->op_next = PL_op->op_next;
 184     }
 185 #endif
 186
 187     SP = args-1;
 188     RETURN;
 189 }
 190
 191
 192 PP(pp_substcont)
 193 {
 194     dVAR;
 195     dSP;
 196     PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 197     PMOP * const pm = (PMOP*) cLOGOP->op_other;
 198     SV * const dstr = cx->sb_dstr;
 199     char *s = cx->sb_s;
 200     char *m = cx->sb_m;
 201     char *orig = cx->sb_orig;
 202     REGEXP * const rx = cx->sb_rx;
 203     SV *nsv = NULL;
 204     REGEXP *old = PM_GETRE(pm);
 205
 206     PERL_ASYNC_CHECK();
 207
 208     if(old != rx) {
 209         if(old)
 210             ReREFCNT_dec(old);
 211         PM_SETRE(pm,ReREFCNT_inc(rx));
 212     }
 213
 214     rxres_restore(&cx->sb_rxres, rx);
 215
 216     if (cx->sb_iters++) {
 217         const I32 saviters = cx->sb_iters;
 218         if (cx->sb_iters > cx->sb_maxiters)
 219             DIE(aTHX_ "Substitution loop");
 220
 221         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
 222
 223         /* See "how taint works" above pp_subst() */
 224         if (SvTAINTED(TOPs))
 225             cx->sb_rxtainted |= SUBST_TAINT_REPL;
 226         sv_catsv_nomg(dstr, POPs);
 227         if (CxONCE(cx) || s < orig ||
 228                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 229                              (s == m), cx->sb_targ, NULL,
 230                     (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
 231         {
 232             SV *targ = cx->sb_targ;
 233
 234             assert(cx->sb_strend >= s);
 235             if(cx->sb_strend > s) {
 236                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 237                       sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 238                  else
 239                       sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
 240             }
 241             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 242                 cx->sb_rxtainted |= SUBST_TAINT_PAT;
 243
 244             if (pm->op_pmflags & PMf_NONDESTRUCT) {
 245                 PUSHs(dstr);
 246                 /* From here on down we're using the copy, and leaving the
 247                    original untouched.  */
 248                 targ = dstr;
 249             }
 250             else {
 251                 SV_CHECK_THINKFIRST_COW_DROP(targ);
 252                 if (isGV(targ)) Perl_croak_no_modify();
 253                 SvPV_free(targ);
 254                 SvPV_set(targ, SvPVX(dstr));
 255                 SvCUR_set(targ, SvCUR(dstr));
 256                 SvLEN_set(targ, SvLEN(dstr));
 257                 if (DO_UTF8(dstr))
 258                     SvUTF8_on(targ);
 259                 SvPV_set(dstr, NULL);
 260
 261                 PL_tainted = 0;
 262                 mPUSHi(saviters - 1);
 263
 264                 (void)SvPOK_only_UTF8(targ);
 265             }
 266
 267             /* update the taint state of various various variables in
 268              * preparation for final exit.
 269              * See "how taint works" above pp_subst() */
 270             if (TAINTING_get) {
 271                 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 272                     ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 273                                     == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 274                 )
 275                     (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 276
 277                 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
 278                     && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
 279                 )
 280                     SvTAINTED_on(TOPs);  /* taint return value */
 281                 /* needed for mg_set below */
 282                 TAINT_set(
 283                     cBOOL(cx->sb_rxtainted &
 284                           (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
 285                 );
 286                 SvTAINT(TARG);
 287             }
 288             /* PL_tainted must be correctly set for this mg_set */
 289             SvSETMAGIC(TARG);
 290             TAINT_NOT;
 291             LEAVE_SCOPE(cx->sb_oldsave);
 292             POPSUBST(cx);
 293             PERL_ASYNC_CHECK();
 294             RETURNOP(pm->op_next);
 295             assert(0); /* NOTREACHED */
 296         }
 297         cx->sb_iters = saviters;
 298     }
 299     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 300         m = s;
 301         s = orig;
 302         assert(!RX_SUBOFFSET(rx));
 303         cx->sb_orig = orig = RX_SUBBEG(rx);
 304         s = orig + (m - s);
 305         cx->sb_strend = s + (cx->sb_strend - m);
 306     }
 307     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 308     if (m > s) {
 309         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 310             sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
 311         else
 312             sv_catpvn_nomg(dstr, s, m-s);
 313     }
 314     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 315     { /* Update the pos() information. */
 316         SV * const sv
 317             = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
 318         MAGIC *mg;
 319         if (!(mg = mg_find_mglob(sv))) {
 320             mg = sv_magicext_mglob(sv);
 321         }
 322         assert(SvPOK(dstr));
 323         MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig);
 324     }
 325     if (old != rx)
 326         (void)ReREFCNT_inc(rx);
 327     /* update the taint state of various various variables in preparation
 328      * for calling the code block.
 329      * See "how taint works" above pp_subst() */
 330     if (TAINTING_get) {
 331         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 332             cx->sb_rxtainted |= SUBST_TAINT_PAT;
 333
 334         if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 335             ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 336                             == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 337         )
 338             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 339
 340         if (cx->sb_iters > 1 && (cx->sb_rxtainted &
 341                         (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
 342             SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
 343                          ? cx->sb_dstr : cx->sb_targ);
 344         TAINT_NOT;
 345     }
 346     rxres_save(&cx->sb_rxres, rx);
 347     PL_curpm = pm;
 348     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 349 }
 350
 351 void
 352 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 353 {
 354     UV *p = (UV*)*rsp;
 355     U32 i;
 356
 357     PERL_ARGS_ASSERT_RXRES_SAVE;
 358     PERL_UNUSED_CONTEXT;
 359
 360     if (!p || p[1] < RX_NPARENS(rx)) {
 361 #ifdef PERL_ANY_COW
 362         i = 7 + (RX_NPARENS(rx)+1) * 2;
 363 #else
 364         i = 6 + (RX_NPARENS(rx)+1) * 2;
 365 #endif
 366         if (!p)
 367             Newx(p, i, UV);
 368         else
 369             Renew(p, i, UV);
 370         *rsp = (void*)p;
 371     }
 372
 373     /* what (if anything) to free on croak */
 374     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 375     RX_MATCH_COPIED_off(rx);
 376     *p++ = RX_NPARENS(rx);
 377
 378 #ifdef PERL_ANY_COW
 379     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 380     RX_SAVED_COPY(rx) = NULL;
 381 #endif
 382
 383     *p++ = PTR2UV(RX_SUBBEG(rx));
 384     *p++ = (UV)RX_SUBLEN(rx);
 385     *p++ = (UV)RX_SUBOFFSET(rx);
 386     *p++ = (UV)RX_SUBCOFFSET(rx);
 387     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 388         *p++ = (UV)RX_OFFS(rx)[i].start;
 389         *p++ = (UV)RX_OFFS(rx)[i].end;
 390     }
 391 }
 392
 393 static void
 394 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 395 {
 396     UV *p = (UV*)*rsp;
 397     U32 i;
 398
 399     PERL_ARGS_ASSERT_RXRES_RESTORE;
 400     PERL_UNUSED_CONTEXT;
 401
 402     RX_MATCH_COPY_FREE(rx);
 403     RX_MATCH_COPIED_set(rx, *p);
 404     *p++ = 0;
 405     RX_NPARENS(rx) = *p++;
 406
 407 #ifdef PERL_ANY_COW
 408     if (RX_SAVED_COPY(rx))
 409         SvREFCNT_dec (RX_SAVED_COPY(rx));
 410     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 411     *p++ = 0;
 412 #endif
 413
 414     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 415     RX_SUBLEN(rx) = (I32)(*p++);
 416     RX_SUBOFFSET(rx) = (I32)*p++;
 417     RX_SUBCOFFSET(rx) = (I32)*p++;
 418     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 419         RX_OFFS(rx)[i].start = (I32)(*p++);
 420         RX_OFFS(rx)[i].end = (I32)(*p++);
 421     }
 422 }
 423
 424 static void
 425 S_rxres_free(pTHX_ void **rsp)
 426 {
 427     UV * const p = (UV*)*rsp;
 428
 429     PERL_ARGS_ASSERT_RXRES_FREE;
 430     PERL_UNUSED_CONTEXT;
 431
 432     if (p) {
 433         void *tmp = INT2PTR(char*,*p);
 434 #ifdef PERL_POISON
 435 #ifdef PERL_ANY_COW
 436         U32 i = 9 + p[1] * 2;
 437 #else
 438         U32 i = 8 + p[1] * 2;
 439 #endif
 440 #endif
 441
 442 #ifdef PERL_ANY_COW
 443         SvREFCNT_dec (INT2PTR(SV*,p[2]));
 444 #endif
 445 #ifdef PERL_POISON
 446         PoisonFree(p, i, sizeof(UV));
 447 #endif
 448
 449         Safefree(tmp);
 450         Safefree(p);
 451         *rsp = NULL;
 452     }
 453 }
 454
 455 #define FORM_NUM_BLANK (1<<30)
 456 #define FORM_NUM_POINT (1<<29)
 457
 458 PP(pp_formline)
 459 {
 460     dVAR; dSP; dMARK; dORIGMARK;
 461     SV * const tmpForm = *++MARK;
 462     SV *formsv;             /* contains text of original format */
 463     U32 *fpc;       /* format ops program counter */
 464     char *t;        /* current append position in target string */
 465     const char *f;          /* current position in format string */
 466     I32 arg;
 467     SV *sv = NULL; /* current item */
 468     const char *item = NULL;/* string value of current item */
 469     I32 itemsize  = 0;      /* length (chars) of item, possibly truncated */
 470     I32 itembytes = 0;      /* as itemsize, but length in bytes */
 471     I32 fieldsize = 0;      /* width of current field */
 472     I32 lines = 0;          /* number of lines that have been output */
 473     bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
 474     const char *chophere = NULL; /* where to chop current item */
 475     STRLEN linemark = 0;    /* pos of start of line in output */
 476     NV value;
 477     bool gotsome = FALSE;   /* seen at least one non-blank item on this line */
 478     STRLEN len;             /* length of current sv */
 479     STRLEN linemax;         /* estimate of output size in bytes */
 480     bool item_is_utf8 = FALSE;
 481     bool targ_is_utf8 = FALSE;
 482     const char *fmt;
 483     MAGIC *mg = NULL;
 484     U8 *source;             /* source of bytes to append */
 485     STRLEN to_copy;         /* how may bytes to append */
 486     char trans;             /* what chars to translate */
 487
 488     mg = doparseform(tmpForm);
 489
 490     fpc = (U32*)mg->mg_ptr;
 491     /* the actual string the format was compiled from.
 492      * with overload etc, this may not match tmpForm */
 493     formsv = mg->mg_obj;
 494
 495
 496     SvPV_force(PL_formtarget, len);
 497     if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
 498         SvTAINTED_on(PL_formtarget);
 499     if (DO_UTF8(PL_formtarget))
 500         targ_is_utf8 = TRUE;
 501     linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
 502     t = SvGROW(PL_formtarget, len + linemax + 1);
 503     /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
 504     t += len;
 505     f = SvPV_const(formsv, len);
 506
 507     for (;;) {
 508         DEBUG_f( {
 509             const char *name = "???";
 510             arg = -1;
 511             switch (*fpc) {
 512             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 513             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 514             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 515             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 516             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 517
 518             case FF_CHECKNL:    name = "CHECKNL";       break;
 519             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 520             case FF_SPACE:      name = "SPACE";         break;
 521             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 522             case FF_ITEM:       name = "ITEM";          break;
 523             case FF_CHOP:       name = "CHOP";          break;
 524             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 525             case FF_NEWLINE:    name = "NEWLINE";       break;
 526             case FF_MORE:       name = "MORE";          break;
 527             case FF_LINEMARK:   name = "LINEMARK";      break;
 528             case FF_END:        name = "END";           break;
 529             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 530             case FF_LINESNGL:   name = "LINESNGL";      break;
 531             }
 532             if (arg >= 0)
 533                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 534             else
 535                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 536         } );
 537         switch (*fpc++) {
 538         case FF_LINEMARK: /* start (or end) of a line */
 539             linemark = t - SvPVX(PL_formtarget);
 540             lines++;
 541             gotsome = FALSE;
 542             break;
 543
 544         case FF_LITERAL: /* append <arg> literal chars */
 545             to_copy = *fpc++;
 546             source = (U8 *)f;
 547             f += to_copy;
 548             trans = '~';
 549             item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
 550             goto append;
 551
 552         case FF_SKIP: /* skip <arg> chars in format */
 553             f += *fpc++;
 554             break;
 555
 556         case FF_FETCH: /* get next item and set field size to <arg> */
 557             arg = *fpc++;
 558             f += arg;
 559             fieldsize = arg;
 560
 561             if (MARK < SP)
 562                 sv = *++MARK;
 563             else {
 564                 sv = &PL_sv_no;
 565                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 566             }
 567             if (SvTAINTED(sv))
 568                 SvTAINTED_on(PL_formtarget);
 569             break;
 570
 571         case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
 572             {
 573                 const char *s = item = SvPV_const(sv, len);
 574                 const char *send = s + len;
 575
 576                 itemsize = 0;
 577                 item_is_utf8 = DO_UTF8(sv);
 578                 while (s < send) {
 579                     if (!isCNTRL(*s))
 580                         gotsome = TRUE;
 581                     else if (*s == '\n')
 582                         break;
 583
 584                     if (item_is_utf8)
 585                         s += UTF8SKIP(s);
 586                     else
 587                         s++;
 588                     itemsize++;
 589                     if (itemsize == fieldsize)
 590                         break;
 591                 }
 592                 itembytes = s - item;
 593                 break;
 594             }
 595
 596         case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
 597             {
 598                 const char *s = item = SvPV_const(sv, len);
 599                 const char *send = s + len;
 600                 I32 size = 0;
 601
 602                 chophere = NULL;
 603                 item_is_utf8 = DO_UTF8(sv);
 604                 while (s < send) {
 605                     /* look for a legal split position */
 606                     if (isSPACE(*s)) {
 607                         if (*s == '\r') {
 608                             chophere = s;
 609                             itemsize = size;
 610                             break;
 611                         }
 612                         if (chopspace) {
 613                             /* provisional split point */
 614                             chophere = s;
 615                             itemsize = size;
 616                         }
 617                         /* we delay testing fieldsize until after we've
 618                          * processed the possible split char directly
 619                          * following the last field char; so if fieldsize=3
 620                          * and item="a b cdef", we consume "a b", not "a".
 621                          * Ditto further down.
 622                          */
 623                         if (size == fieldsize)
 624                             break;
 625                     }
 626                     else {
 627                         if (strchr(PL_chopset, *s)) {
 628                             /* provisional split point */
 629                             /* for a non-space split char, we include
 630                              * the split char; hence the '+1' */
 631                             chophere = s + 1;
 632                             itemsize = size;
 633                         }
 634                         if (size == fieldsize)
 635                             break;
 636                         if (!isCNTRL(*s))
 637                             gotsome = TRUE;
 638                     }
 639
 640                     if (item_is_utf8)
 641                         s += UTF8SKIP(s);
 642                     else
 643                         s++;
 644                     size++;
 645                 }
 646                 if (!chophere || s == send) {
 647                     chophere = s;
 648                     itemsize = size;
 649                 }
 650                 itembytes = chophere - item;
 651
 652                 break;
 653             }
 654
 655         case FF_SPACE: /* append padding space (diff of field, item size) */
 656             arg = fieldsize - itemsize;
 657             if (arg) {
 658                 fieldsize -= arg;
 659                 while (arg-- > 0)
 660                     *t++ = ' ';
 661             }
 662             break;
 663
 664         case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
 665             arg = fieldsize - itemsize;
 666             if (arg) {
 667                 arg /= 2;
 668                 fieldsize -= arg;
 669                 while (arg-- > 0)
 670                     *t++ = ' ';
 671             }
 672             break;
 673
 674         case FF_ITEM: /* append a text item, while blanking ctrl chars */
 675             to_copy = itembytes;
 676             source = (U8 *)item;
 677             trans = 1;
 678             goto append;
 679
 680         case FF_CHOP: /* (for ^*) chop the current item */
 681             {
 682                 const char *s = chophere;
 683                 if (chopspace) {
 684                     while (isSPACE(*s))
 685                         s++;
 686                 }
 687                 if (SvPOKp(sv))
 688                     sv_chop(sv,s);
 689                 else
 690                     /* tied, overloaded or similar strangeness.
 691                      * Do it the hard way */
 692                     sv_setpvn(sv, s, len - (s-item));
 693                 SvSETMAGIC(sv);
 694                 break;
 695             }
 696
 697         case FF_LINESNGL: /* process ^*  */
 698             chopspace = 0;
 699             /* FALLTHROUGH */
 700
 701         case FF_LINEGLOB: /* process @*  */
 702             {
 703                 const bool oneline = fpc[-1] == FF_LINESNGL;
 704                 const char *s = item = SvPV_const(sv, len);
 705                 const char *const send = s + len;
 706
 707                 item_is_utf8 = DO_UTF8(sv);
 708                 if (!len)
 709                     break;
 710                 trans = 0;
 711                 gotsome = TRUE;
 712                 chophere = s + len;
 713                 source = (U8 *) s;
 714                 to_copy = len;
 715                 while (s < send) {
 716                     if (*s++ == '\n') {
 717                         if (oneline) {
 718                             to_copy = s - item - 1;
 719                             chophere = s;
 720                             break;
 721                         } else {
 722                             if (s == send) {
 723                                 to_copy--;
 724                             } else
 725                                 lines++;
 726                         }
 727                     }
 728                 }
 729             }
 730
 731         append:
 732             /* append to_copy bytes from source to PL_formstring.
 733              * item_is_utf8 implies source is utf8.
 734              * if trans, translate certain characters during the copy */
 735             {
 736                 U8 *tmp = NULL;
 737                 STRLEN grow = 0;
 738
 739                 SvCUR_set(PL_formtarget,
 740                           t - SvPVX_const(PL_formtarget));
 741
 742                 if (targ_is_utf8 && !item_is_utf8) {
 743                     source = tmp = bytes_to_utf8(source, &to_copy);
 744                 } else {
 745                     if (item_is_utf8 && !targ_is_utf8) {
 746                         U8 *s;
 747                         /* Upgrade targ to UTF8, and then we reduce it to
 748                            a problem we have a simple solution for.
 749                            Don't need get magic.  */
 750                         sv_utf8_upgrade_nomg(PL_formtarget);
 751                         targ_is_utf8 = TRUE;
 752                         /* re-calculate linemark */
 753                         s = (U8*)SvPVX(PL_formtarget);
 754                         /* the bytes we initially allocated to append the
 755                          * whole line may have been gobbled up during the
 756                          * upgrade, so allocate a whole new line's worth
 757                          * for safety */
 758                         grow = linemax;
 759                         while (linemark--)
 760                             s += UTF8SKIP(s);
 761                         linemark = s - (U8*)SvPVX(PL_formtarget);
 762                     }
 763                     /* Easy. They agree.  */
 764                     assert (item_is_utf8 == targ_is_utf8);
 765                 }
 766                 if (!trans)
 767                     /* @* and ^* are the only things that can exceed
 768                      * the linemax, so grow by the output size, plus
 769                      * a whole new form's worth in case of any further
 770                      * output */
 771                     grow = linemax + to_copy;
 772                 if (grow)
 773                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
 774                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 775
 776                 Copy(source, t, to_copy, char);
 777                 if (trans) {
 778                     /* blank out ~ or control chars, depending on trans.
 779                      * works on bytes not chars, so relies on not
 780                      * matching utf8 continuation bytes */
 781                     U8 *s = (U8*)t;
 782                     U8 *send = s + to_copy;
 783                     while (s < send) {
 784                         const int ch = *s;
 785                         if (trans == '~' ? (ch == '~') : isCNTRL(ch))
 786                             *s = ' ';
 787                         s++;
 788                     }
 789                 }
 790
 791                 t += to_copy;
 792                 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 793                 if (tmp)
 794                     Safefree(tmp);
 795                 break;
 796             }
 797
 798         case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
 799             arg = *fpc++;
 800 #if defined(USE_LONG_DOUBLE)
 801             fmt = (const char *)
 802                 ((arg & FORM_NUM_POINT) ?
 803                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 804 #else
 805             fmt = (const char *)
 806                 ((arg & FORM_NUM_POINT) ?
 807                  "%#0*.*f"              : "%0*.*f");
 808 #endif
 809             goto ff_dec;
 810
 811         case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
 812             arg = *fpc++;
 813 #if defined(USE_LONG_DOUBLE)
 814             fmt = (const char *)
 815                 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 816 #else
 817             fmt = (const char *)
 818                 ((arg & FORM_NUM_POINT) ? "%#*.*f"              : "%*.*f");
 819 #endif
 820         ff_dec:
 821             /* If the field is marked with ^ and the value is undefined,
 822                blank it out. */
 823             if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
 824                 arg = fieldsize;
 825                 while (arg--)
 826                     *t++ = ' ';
 827                 break;
 828             }
 829             gotsome = TRUE;
 830             value = SvNV(sv);
 831             /* overflow evidence */
 832             if (num_overflow(value, fieldsize, arg)) {
 833                 arg = fieldsize;
 834                 while (arg--)
 835                     *t++ = '#';
 836                 break;
 837             }
 838             /* Formats aren't yet marked for locales, so assume "yes". */
 839             {
 840                 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
 841                 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
 842                 /* we generate fmt ourselves so it is safe */
 843                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
 844                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
 845                 GCC_DIAG_RESTORE;
 846                 RESTORE_LC_NUMERIC();
 847             }
 848             t += fieldsize;
 849             break;
 850
 851         case FF_NEWLINE: /* delete trailing spaces, then append \n */
 852             f++;
 853             while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
 854             t++;
 855             *t++ = '\n';
 856             break;
 857
 858         case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
 859             arg = *fpc++;
 860             if (gotsome) {
 861                 if (arg) {              /* repeat until fields exhausted? */
 862                     fpc--;
 863                     goto end;
 864                 }
 865             }
 866             else {
 867                 t = SvPVX(PL_formtarget) + linemark;
 868                 lines--;
 869             }
 870             break;
 871
 872         case FF_MORE: /* replace long end of string with '...' */
 873             {
 874                 const char *s = chophere;
 875                 const char *send = item + len;
 876                 if (chopspace) {
 877                     while (isSPACE(*s) && (s < send))
 878                         s++;
 879                 }
 880                 if (s < send) {
 881                     char *s1;
 882                     arg = fieldsize - itemsize;
 883                     if (arg) {
 884                         fieldsize -= arg;
 885                         while (arg-- > 0)
 886                             *t++ = ' ';
 887                     }
 888                     s1 = t - 3;
 889                     if (strnEQ(s1,"   ",3)) {
 890                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 891                             s1--;
 892                     }
 893                     *s1++ = '.';
 894                     *s1++ = '.';
 895                     *s1++ = '.';
 896                 }
 897                 break;
 898             }
 899
 900         case FF_END: /* tidy up, then return */
 901         end:
 902             assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
 903             *t = '\0';
 904             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 905             if (targ_is_utf8)
 906                 SvUTF8_on(PL_formtarget);
 907             FmLINES(PL_formtarget) += lines;
 908             SP = ORIGMARK;
 909             if (fpc[-1] == FF_BLANK)
 910                 RETURNOP(cLISTOP->op_first);
 911             else
 912                 RETPUSHYES;
 913         }
 914     }
 915 }
 916
 917 PP(pp_grepstart)
 918 {
 919     dVAR; dSP;
 920     SV *src;
 921
 922     if (PL_stack_base + *PL_markstack_ptr == SP) {
 923         (void)POPMARK;
 924         if (GIMME_V == G_SCALAR)
 925             mXPUSHi(0);
 926         RETURNOP(PL_op->op_next->op_next);
 927     }
 928     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 929     Perl_pp_pushmark(aTHX);                             /* push dst */
 930     Perl_pp_pushmark(aTHX);                             /* push src */
 931     ENTER_with_name("grep");                                    /* enter outer scope */
 932
 933     SAVETMPS;
 934     if (PL_op->op_private & OPpGREP_LEX)
 935         SAVESPTR(PAD_SVl(PL_op->op_targ));
 936     else
 937         SAVE_DEFSV;
 938     ENTER_with_name("grep_item");                                       /* enter inner scope */
 939     SAVEVPTR(PL_curpm);
 940
 941     src = PL_stack_base[*PL_markstack_ptr];
 942     if (SvPADTMP(src)) {
 943         assert(!IS_PADGV(src));
 944         src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
 945         PL_tmps_floor++;
 946     }
 947     SvTEMP_off(src);
 948     if (PL_op->op_private & OPpGREP_LEX)
 949         PAD_SVl(PL_op->op_targ) = src;
 950     else
 951         DEFSV_set(src);
 952
 953     PUTBACK;
 954     if (PL_op->op_type == OP_MAPSTART)
 955         Perl_pp_pushmark(aTHX);                 /* push top */
 956     return ((LOGOP*)PL_op->op_next)->op_other;
 957 }
 958
 959 PP(pp_mapwhile)
 960 {
 961     dVAR; dSP;
 962     const I32 gimme = GIMME_V;
 963     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 964     I32 count;
 965     I32 shift;
 966     SV** src;
 967     SV** dst;
 968
 969     /* first, move source pointer to the next item in the source list */
 970     ++PL_markstack_ptr[-1];
 971
 972     /* if there are new items, push them into the destination list */
 973     if (items && gimme != G_VOID) {
 974         /* might need to make room back there first */
 975         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 976             /* XXX this implementation is very pessimal because the stack
 977              * is repeatedly extended for every set of items.  Is possible
 978              * to do this without any stack extension or copying at all
 979              * by maintaining a separate list over which the map iterates
 980              * (like foreach does). --gsar */
 981
 982             /* everything in the stack after the destination list moves
 983              * towards the end the stack by the amount of room needed */
 984             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 985
 986             /* items to shift up (accounting for the moved source pointer) */
 987             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 988
 989             /* This optimization is by Ben Tilly and it does
 990              * things differently from what Sarathy (gsar)
 991              * is describing.  The downside of this optimization is
 992              * that leaves "holes" (uninitialized and hopefully unused areas)
 993              * to the Perl stack, but on the other hand this
 994              * shouldn't be a problem.  If Sarathy's idea gets
 995              * implemented, this optimization should become
 996              * irrelevant.  --jhi */
 997             if (shift < count)
 998                 shift = count; /* Avoid shifting too often --Ben Tilly */
 999
1000             EXTEND(SP,shift);
1001             src = SP;
1002             dst = (SP += shift);
1003             PL_markstack_ptr[-1] += shift;
1004             *PL_markstack_ptr += shift;
1005             while (count--)
1006                 *dst-- = *src--;
1007         }
1008         /* copy the new items down to the destination list */
1009         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1010         if (gimme == G_ARRAY) {
1011             /* add returned items to the collection (making mortal copies
1012              * if necessary), then clear the current temps stack frame
1013              * *except* for those items. We do this splicing the items
1014              * into the start of the tmps frame (so some items may be on
1015              * the tmps stack twice), then moving PL_tmps_floor above
1016              * them, then freeing the frame. That way, the only tmps that
1017              * accumulate over iterations are the return values for map.
1018              * We have to do to this way so that everything gets correctly
1019              * freed if we die during the map.
1020              */
1021             I32 tmpsbase;
1022             I32 i = items;
1023             /* make space for the slice */
1024             EXTEND_MORTAL(items);
1025             tmpsbase = PL_tmps_floor + 1;
1026             Move(PL_tmps_stack + tmpsbase,
1027                  PL_tmps_stack + tmpsbase + items,
1028                  PL_tmps_ix - PL_tmps_floor,
1029                  SV*);
1030             PL_tmps_ix += items;
1031
1032             while (i-- > 0) {
1033                 SV *sv = POPs;
1034                 if (!SvTEMP(sv))
1035                     sv = sv_mortalcopy(sv);
1036                 *dst-- = sv;
1037                 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1038             }
1039             /* clear the stack frame except for the items */
1040             PL_tmps_floor += items;
1041             FREETMPS;
1042             /* FREETMPS may have cleared the TEMP flag on some of the items */
1043             i = items;
1044             while (i-- > 0)
1045                 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1046         }
1047         else {
1048             /* scalar context: we don't care about which values map returns
1049              * (we use undef here). And so we certainly don't want to do mortal
1050              * copies of meaningless values. */
1051             while (items-- > 0) {
1052                 (void)POPs;
1053                 *dst-- = &PL_sv_undef;
1054             }
1055             FREETMPS;
1056         }
1057     }
1058     else {
1059         FREETMPS;
1060     }
1061     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1062
1063     /* All done yet? */
1064     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1065
1066         (void)POPMARK;                          /* pop top */
1067         LEAVE_with_name("grep");                                        /* exit outer scope */
1068         (void)POPMARK;                          /* pop src */
1069         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1070         (void)POPMARK;                          /* pop dst */
1071         SP = PL_stack_base + POPMARK;           /* pop original mark */
1072         if (gimme == G_SCALAR) {
1073             if (PL_op->op_private & OPpGREP_LEX) {
1074                 SV* sv = sv_newmortal();
1075                 sv_setiv(sv, items);
1076                 PUSHs(sv);
1077             }
1078             else {
1079                 dTARGET;
1080                 XPUSHi(items);
1081             }
1082         }
1083         else if (gimme == G_ARRAY)
1084             SP += items;
1085         RETURN;
1086     }
1087     else {
1088         SV *src;
1089
1090         ENTER_with_name("grep_item");                                   /* enter inner scope */
1091         SAVEVPTR(PL_curpm);
1092
1093         /* set $_ to the new source item */
1094         src = PL_stack_base[PL_markstack_ptr[-1]];
1095         if (SvPADTMP(src)) {
1096             assert(!IS_PADGV(src));
1097             src = sv_mortalcopy(src);
1098         }
1099         SvTEMP_off(src);
1100         if (PL_op->op_private & OPpGREP_LEX)
1101             PAD_SVl(PL_op->op_targ) = src;
1102         else
1103             DEFSV_set(src);
1104
1105         RETURNOP(cLOGOP->op_other);
1106     }
1107 }
1108
1109 /* Range stuff. */
1110
1111 PP(pp_range)
1112 {
1113     dVAR;
1114     if (GIMME == G_ARRAY)
1115         return NORMAL;
1116     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1117         return cLOGOP->op_other;
1118     else
1119         return NORMAL;
1120 }
1121
1122 PP(pp_flip)
1123 {
1124     dVAR;
1125     dSP;
1126
1127     if (GIMME == G_ARRAY) {
1128         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1129     }
1130     else {
1131         dTOPss;
1132         SV * const targ = PAD_SV(PL_op->op_targ);
1133         int flip = 0;
1134
1135         if (PL_op->op_private & OPpFLIP_LINENUM) {
1136             if (GvIO(PL_last_in_gv)) {
1137                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1138             }
1139             else {
1140                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1141                 if (gv && GvSV(gv))
1142                     flip = SvIV(sv) == SvIV(GvSV(gv));
1143             }
1144         } else {
1145             flip = SvTRUE(sv);
1146         }
1147         if (flip) {
1148             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1149             if (PL_op->op_flags & OPf_SPECIAL) {
1150                 sv_setiv(targ, 1);
1151                 SETs(targ);
1152                 RETURN;
1153             }
1154             else {
1155                 sv_setiv(targ, 0);
1156                 SP--;
1157                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1158             }
1159         }
1160         sv_setpvs(TARG, "");
1161         SETs(targ);
1162         RETURN;
1163     }
1164 }
1165
1166 /* This code tries to decide if "$left .. $right" should use the
1167    magical string increment, or if the range is numeric (we make
1168    an exception for .."0" [#18165]). AMS 20021031. */
1169
1170 #define RANGE_IS_NUMERIC(left,right) ( \
1171         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1172         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1173         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1174           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1175          && (!SvOK(right) || looks_like_number(right))))
1176
1177 PP(pp_flop)
1178 {
1179     dVAR; dSP;
1180
1181     if (GIMME == G_ARRAY) {
1182         dPOPPOPssrl;
1183
1184         SvGETMAGIC(left);
1185         SvGETMAGIC(right);
1186
1187         if (RANGE_IS_NUMERIC(left,right)) {
1188             IV i, j, n;
1189             if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1190                 (SvOK(right) && (SvIOK(right)
1191                                  ? SvIsUV(right) && SvUV(right) > IV_MAX
1192                                  : SvNV_nomg(right) > IV_MAX)))
1193                 DIE(aTHX_ "Range iterator outside integer range");
1194             i = SvIV_nomg(left);
1195             j = SvIV_nomg(right);
1196             if (j >= i) {
1197                 /* Dance carefully around signed max. */
1198                 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1199                 if (!overflow) {
1200                     n = j - i + 1;
1201                     /* The wraparound of signed integers is undefined
1202                      * behavior, but here we aim for count >=1, and
1203                      * negative count is just wrong. */
1204                     if (n < 1)
1205                         overflow = TRUE;
1206                 }
1207                 if (overflow)
1208                     Perl_croak(aTHX_ "Out of memory during list extend");
1209                 EXTEND_MORTAL(n);
1210                 EXTEND(SP, n);
1211             }
1212             else
1213                 n = 0;
1214             while (n--) {
1215                 SV * const sv = sv_2mortal(newSViv(i++));
1216                 PUSHs(sv);
1217             }
1218         }
1219         else {
1220             STRLEN len, llen;
1221             const char * const lpv = SvPV_nomg_const(left, llen);
1222             const char * const tmps = SvPV_nomg_const(right, len);
1223
1224             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1225             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1226                 XPUSHs(sv);
1227                 if (strEQ(SvPVX_const(sv),tmps))
1228                     break;
1229                 sv = sv_2mortal(newSVsv(sv));
1230                 sv_inc(sv);
1231             }
1232         }
1233     }
1234     else {
1235         dTOPss;
1236         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1237         int flop = 0;
1238         sv_inc(targ);
1239
1240         if (PL_op->op_private & OPpFLIP_LINENUM) {
1241             if (GvIO(PL_last_in_gv)) {
1242                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1243             }
1244             else {
1245                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1246                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1247             }
1248         }
1249         else {
1250             flop = SvTRUE(sv);
1251         }
1252
1253         if (flop) {
1254             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1255             sv_catpvs(targ, "E0");
1256         }
1257         SETs(targ);
1258     }
1259
1260     RETURN;
1261 }
1262
1263 /* Control. */
1264
1265 static const char * const context_name[] = {
1266     "pseudo-block",
1267     NULL, /* CXt_WHEN never actually needs "block" */
1268     NULL, /* CXt_BLOCK never actually needs "block" */
1269     NULL, /* CXt_GIVEN never actually needs "block" */
1270     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1271     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1272     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1273     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1274     "subroutine",
1275     "format",
1276     "eval",
1277     "substitution",
1278 };
1279
1280 STATIC I32
1281 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1282 {
1283     dVAR;
1284     I32 i;
1285
1286     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1287
1288     for (i = cxstack_ix; i >= 0; i--) {
1289         const PERL_CONTEXT * const cx = &cxstack[i];
1290         switch (CxTYPE(cx)) {
1291         case CXt_SUBST:
1292         case CXt_SUB:
1293         case CXt_FORMAT:
1294         case CXt_EVAL:
1295         case CXt_NULL:
1296             /* diag_listed_as: Exiting subroutine via %s */
1297             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1298                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1299             if (CxTYPE(cx) == CXt_NULL)
1300                 return -1;
1301             break;
1302         case CXt_LOOP_LAZYIV:
1303         case CXt_LOOP_LAZYSV:
1304         case CXt_LOOP_FOR:
1305         case CXt_LOOP_PLAIN:
1306           {
1307             STRLEN cx_label_len = 0;
1308             U32 cx_label_flags = 0;
1309             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1310             if (!cx_label || !(
1311                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1312                         (flags & SVf_UTF8)
1313                             ? (bytes_cmp_utf8(
1314                                         (const U8*)cx_label, cx_label_len,
1315                                         (const U8*)label, len) == 0)
1316                             : (bytes_cmp_utf8(
1317                                         (const U8*)label, len,
1318                                         (const U8*)cx_label, cx_label_len) == 0)
1319                     : (len == cx_label_len && ((cx_label == label)
1320                                     || memEQ(cx_label, label, len))) )) {
1321                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1322                         (long)i, cx_label));
1323                 continue;
1324             }
1325             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1326             return i;
1327           }
1328         }
1329     }
1330     return i;
1331 }
1332
1333
1334
1335 I32
1336 Perl_dowantarray(pTHX)
1337 {
1338     dVAR;
1339     const I32 gimme = block_gimme();
1340     return (gimme == G_VOID) ? G_SCALAR : gimme;
1341 }
1342
1343 I32
1344 Perl_block_gimme(pTHX)
1345 {
1346     dVAR;
1347     const I32 cxix = dopoptosub(cxstack_ix);
1348     if (cxix < 0)
1349         return G_VOID;
1350
1351     switch (cxstack[cxix].blk_gimme) {
1352     case G_VOID:
1353         return G_VOID;
1354     case G_SCALAR:
1355         return G_SCALAR;
1356     case G_ARRAY:
1357         return G_ARRAY;
1358     default:
1359         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1360         assert(0); /* NOTREACHED */
1361         return 0;
1362     }
1363 }
1364
1365 I32
1366 Perl_is_lvalue_sub(pTHX)
1367 {
1368     dVAR;
1369     const I32 cxix = dopoptosub(cxstack_ix);
1370     assert(cxix >= 0);  /* We should only be called from inside subs */
1371
1372     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1373         return CxLVAL(cxstack + cxix);
1374     else
1375         return 0;
1376 }
1377
1378 /* only used by PUSHSUB */
1379 I32
1380 Perl_was_lvalue_sub(pTHX)
1381 {
1382     dVAR;
1383     const I32 cxix = dopoptosub(cxstack_ix-1);
1384     assert(cxix >= 0);  /* We should only be called from inside subs */
1385
1386     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1387         return CxLVAL(cxstack + cxix);
1388     else
1389         return 0;
1390 }
1391
1392 STATIC I32
1393 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1394 {
1395     dVAR;
1396     I32 i;
1397
1398     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1399
1400     for (i = startingblock; i >= 0; i--) {
1401         const PERL_CONTEXT * const cx = &cxstk[i];
1402         switch (CxTYPE(cx)) {
1403         default:
1404             continue;
1405         case CXt_SUB:
1406             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1407              * twice; the first for the normal foo() call, and the second
1408              * for a faked up re-entry into the sub to execute the
1409              * code block. Hide this faked entry from the world. */
1410             if (cx->cx_type & CXp_SUB_RE_FAKE)
1411                 continue;
1412             /* FALLTHROUGH */
1413         case CXt_EVAL:
1414         case CXt_FORMAT:
1415             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1416             return i;
1417         }
1418     }
1419     return i;
1420 }
1421
1422 STATIC I32
1423 S_dopoptoeval(pTHX_ I32 startingblock)
1424 {
1425     dVAR;
1426     I32 i;
1427     for (i = startingblock; i >= 0; i--) {
1428         const PERL_CONTEXT *cx = &cxstack[i];
1429         switch (CxTYPE(cx)) {
1430         default:
1431             continue;
1432         case CXt_EVAL:
1433             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1434             return i;
1435         }
1436     }
1437     return i;
1438 }
1439
1440 STATIC I32
1441 S_dopoptoloop(pTHX_ I32 startingblock)
1442 {
1443     dVAR;
1444     I32 i;
1445     for (i = startingblock; i >= 0; i--) {
1446         const PERL_CONTEXT * const cx = &cxstack[i];
1447         switch (CxTYPE(cx)) {
1448         case CXt_SUBST:
1449         case CXt_SUB:
1450         case CXt_FORMAT:
1451         case CXt_EVAL:
1452         case CXt_NULL:
1453             /* diag_listed_as: Exiting subroutine via %s */
1454             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1455                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1456             if ((CxTYPE(cx)) == CXt_NULL)
1457                 return -1;
1458             break;
1459         case CXt_LOOP_LAZYIV:
1460         case CXt_LOOP_LAZYSV:
1461         case CXt_LOOP_FOR:
1462         case CXt_LOOP_PLAIN:
1463             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1464             return i;
1465         }
1466     }
1467     return i;
1468 }
1469
1470 STATIC I32
1471 S_dopoptogiven(pTHX_ I32 startingblock)
1472 {
1473     dVAR;
1474     I32 i;
1475     for (i = startingblock; i >= 0; i--) {
1476         const PERL_CONTEXT *cx = &cxstack[i];
1477         switch (CxTYPE(cx)) {
1478         default:
1479             continue;
1480         case CXt_GIVEN:
1481             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1482             return i;
1483         case CXt_LOOP_PLAIN:
1484             assert(!CxFOREACHDEF(cx));
1485             break;
1486         case CXt_LOOP_LAZYIV:
1487         case CXt_LOOP_LAZYSV:
1488         case CXt_LOOP_FOR:
1489             if (CxFOREACHDEF(cx)) {
1490                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1491                 return i;
1492             }
1493         }
1494     }
1495     return i;
1496 }
1497
1498 STATIC I32
1499 S_dopoptowhen(pTHX_ I32 startingblock)
1500 {
1501     dVAR;
1502     I32 i;
1503     for (i = startingblock; i >= 0; i--) {
1504         const PERL_CONTEXT *cx = &cxstack[i];
1505         switch (CxTYPE(cx)) {
1506         default:
1507             continue;
1508         case CXt_WHEN:
1509             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1510             return i;
1511         }
1512     }
1513     return i;
1514 }
1515
1516 void
1517 Perl_dounwind(pTHX_ I32 cxix)
1518 {
1519     dVAR;
1520     I32 optype;
1521
1522     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1523         return;
1524
1525     while (cxstack_ix > cxix) {
1526         SV *sv;
1527         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1528         DEBUG_CX("UNWIND");                                             \
1529         /* Note: we don't need to restore the base context info till the end. */
1530         switch (CxTYPE(cx)) {
1531         case CXt_SUBST:
1532             POPSUBST(cx);
1533             continue;  /* not break */
1534         case CXt_SUB:
1535             POPSUB(cx,sv);
1536             LEAVESUB(sv);
1537             break;
1538         case CXt_EVAL:
1539             POPEVAL(cx);
1540             break;
1541         case CXt_LOOP_LAZYIV:
1542         case CXt_LOOP_LAZYSV:
1543         case CXt_LOOP_FOR:
1544         case CXt_LOOP_PLAIN:
1545             POPLOOP(cx);
1546             break;
1547         case CXt_NULL:
1548             break;
1549         case CXt_FORMAT:
1550             POPFORMAT(cx);
1551             break;
1552         }
1553         cxstack_ix--;
1554     }
1555     PERL_UNUSED_VAR(optype);
1556 }
1557
1558 void
1559 Perl_qerror(pTHX_ SV *err)
1560 {
1561     dVAR;
1562
1563     PERL_ARGS_ASSERT_QERROR;
1564
1565     if (PL_in_eval) {
1566         if (PL_in_eval & EVAL_KEEPERR) {
1567                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1568                                                     SVfARG(err));
1569         }
1570         else
1571             sv_catsv(ERRSV, err);
1572     }
1573     else if (PL_errors)
1574         sv_catsv(PL_errors, err);
1575     else
1576         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1577     if (PL_parser)
1578         ++PL_parser->error_count;
1579 }
1580
1581 void
1582 Perl_die_unwind(pTHX_ SV *msv)
1583 {
1584     dVAR;
1585     SV *exceptsv = sv_mortalcopy(msv);
1586     U8 in_eval = PL_in_eval;
1587     PERL_ARGS_ASSERT_DIE_UNWIND;
1588
1589     if (in_eval) {
1590         I32 cxix;
1591         I32 gimme;
1592
1593         /*
1594          * Historically, perl used to set ERRSV ($@) early in the die
1595          * process and rely on it not getting clobbered during unwinding.
1596          * That sucked, because it was liable to get clobbered, so the
1597          * setting of ERRSV used to emit the exception from eval{} has
1598          * been moved to much later, after unwinding (see just before
1599          * JMPENV_JUMP below).  However, some modules were relying on the
1600          * early setting, by examining $@ during unwinding to use it as
1601          * a flag indicating whether the current unwinding was caused by
1602          * an exception.  It was never a reliable flag for that purpose,
1603          * being totally open to false positives even without actual
1604          * clobberage, but was useful enough for production code to
1605          * semantically rely on it.
1606          *
1607          * We'd like to have a proper introspective interface that
1608          * explicitly describes the reason for whatever unwinding
1609          * operations are currently in progress, so that those modules
1610          * work reliably and $@ isn't further overloaded.  But we don't
1611          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1612          * now *additionally* set here, before unwinding, to serve as the
1613          * (unreliable) flag that it used to.
1614          *
1615          * This behaviour is temporary, and should be removed when a
1616          * proper way to detect exceptional unwinding has been developed.
1617          * As of 2010-12, the authors of modules relying on the hack
1618          * are aware of the issue, because the modules failed on
1619          * perls 5.13.{1..7} which had late setting of $@ without this
1620          * early-setting hack.
1621          */
1622         if (!(in_eval & EVAL_KEEPERR)) {
1623             SvTEMP_off(exceptsv);
1624             sv_setsv(ERRSV, exceptsv);
1625         }
1626
1627         if (in_eval & EVAL_KEEPERR) {
1628             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1629                            SVfARG(exceptsv));
1630         }
1631
1632         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1633                && PL_curstackinfo->si_prev)
1634         {
1635             dounwind(-1);
1636             POPSTACK;
1637         }
1638
1639         if (cxix >= 0) {
1640             I32 optype;
1641             SV *namesv;
1642             PERL_CONTEXT *cx;
1643             SV **newsp;
1644             COP *oldcop;
1645             JMPENV *restartjmpenv;
1646             OP *restartop;
1647
1648             if (cxix < cxstack_ix)
1649                 dounwind(cxix);
1650
1651             POPBLOCK(cx,PL_curpm);
1652             if (CxTYPE(cx) != CXt_EVAL) {
1653                 STRLEN msglen;
1654                 const char* message = SvPVx_const(exceptsv, msglen);
1655                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1656                 PerlIO_write(Perl_error_log, message, msglen);
1657                 my_exit(1);
1658             }
1659             POPEVAL(cx);
1660             namesv = cx->blk_eval.old_namesv;
1661             oldcop = cx->blk_oldcop;
1662             restartjmpenv = cx->blk_eval.cur_top_env;
1663             restartop = cx->blk_eval.retop;
1664
1665             if (gimme == G_SCALAR)
1666                 *++newsp = &PL_sv_undef;
1667             PL_stack_sp = newsp;
1668
1669             LEAVE;
1670
1671             /* LEAVE could clobber PL_curcop (see save_re_context())
1672              * XXX it might be better to find a way to avoid messing with
1673              * PL_curcop in save_re_context() instead, but this is a more
1674              * minimal fix --GSAR */
1675             PL_curcop = oldcop;
1676
1677             if (optype == OP_REQUIRE) {
1678                 (void)hv_store(GvHVn(PL_incgv),
1679                                SvPVX_const(namesv),
1680                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1681                                &PL_sv_undef, 0);
1682                 /* note that unlike pp_entereval, pp_require isn't
1683                  * supposed to trap errors. So now that we've popped the
1684                  * EVAL that pp_require pushed, and processed the error
1685                  * message, rethrow the error */
1686                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1687                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1688                                                                     SVs_TEMP)));
1689             }
1690             if (!(in_eval & EVAL_KEEPERR))
1691                 sv_setsv(ERRSV, exceptsv);
1692             PL_restartjmpenv = restartjmpenv;
1693             PL_restartop = restartop;
1694             JMPENV_JUMP(3);
1695             assert(0); /* NOTREACHED */
1696         }
1697     }
1698
1699     write_to_stderr(exceptsv);
1700     my_failure_exit();
1701     assert(0); /* NOTREACHED */
1702 }
1703
1704 PP(pp_xor)
1705 {
1706     dVAR; dSP; dPOPTOPssrl;
1707     if (SvTRUE(left) != SvTRUE(right))
1708         RETSETYES;
1709     else
1710         RETSETNO;
1711 }
1712
1713 /*
1714
1715 =head1 CV Manipulation Functions
1716
1717 =for apidoc caller_cx
1718
1719 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1720 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1721 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1722 stack frame, so C<caller_cx(0, NULL)> will return information for the
1723 immediately-surrounding Perl code.
1724
1725 This function skips over the automatic calls to C<&DB::sub> made on the
1726 behalf of the debugger.  If the stack frame requested was a sub called by
1727 C<DB::sub>, the return value will be the frame for the call to
1728 C<DB::sub>, since that has the correct line number/etc. for the call
1729 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1730 frame for the sub call itself.
1731
1732 =cut
1733 */
1734
1735 const PERL_CONTEXT *
1736 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1737 {
1738     I32 cxix = dopoptosub(cxstack_ix);
1739     const PERL_CONTEXT *cx;
1740     const PERL_CONTEXT *ccstack = cxstack;
1741     const PERL_SI *top_si = PL_curstackinfo;
1742
1743     for (;;) {
1744         /* we may be in a higher stacklevel, so dig down deeper */
1745         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1746             top_si = top_si->si_prev;
1747             ccstack = top_si->si_cxstack;
1748             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1749         }
1750         if (cxix < 0)
1751             return NULL;
1752         /* caller() should not report the automatic calls to &DB::sub */
1753         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1754                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1755             count++;
1756         if (!count--)
1757             break;
1758         cxix = dopoptosub_at(ccstack, cxix - 1);
1759     }
1760
1761     cx = &ccstack[cxix];
1762     if (dbcxp) *dbcxp = cx;
1763
1764     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1765         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1766         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1767            field below is defined for any cx. */
1768         /* caller() should not report the automatic calls to &DB::sub */
1769         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1770             cx = &ccstack[dbcxix];
1771     }
1772
1773     return cx;
1774 }
1775
1776 PP(pp_caller)
1777 {
1778     dVAR;
1779     dSP;
1780     const PERL_CONTEXT *cx;
1781     const PERL_CONTEXT *dbcx;
1782     I32 gimme;
1783     const HEK *stash_hek;
1784     I32 count = 0;
1785     bool has_arg = MAXARG && TOPs;
1786     const COP *lcop;
1787
1788     if (MAXARG) {
1789       if (has_arg)
1790         count = POPi;
1791       else (void)POPs;
1792     }
1793
1794     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1795     if (!cx) {
1796         if (GIMME != G_ARRAY) {
1797             EXTEND(SP, 1);
1798             RETPUSHUNDEF;
1799         }
1800         RETURN;
1801     }
1802
1803     DEBUG_CX("CALLER");
1804     assert(CopSTASH(cx->blk_oldcop));
1805     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1806       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1807       : NULL;
1808     if (GIMME != G_ARRAY) {
1809         EXTEND(SP, 1);
1810         if (!stash_hek)
1811             PUSHs(&PL_sv_undef);
1812         else {
1813             dTARGET;
1814             sv_sethek(TARG, stash_hek);
1815             PUSHs(TARG);
1816         }
1817         RETURN;
1818     }
1819
1820     EXTEND(SP, 11);
1821
1822     if (!stash_hek)
1823         PUSHs(&PL_sv_undef);
1824     else {
1825         dTARGET;
1826         sv_sethek(TARG, stash_hek);
1827         PUSHTARG;
1828     }
1829     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1830     lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling,
1831                        cx->blk_sub.retop, TRUE);
1832     if (!lcop)
1833         lcop = cx->blk_oldcop;
1834     mPUSHi((I32)CopLINE(lcop));
1835     if (!has_arg)
1836         RETURN;
1837     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1838         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1839         /* So is ccstack[dbcxix]. */
1840         if (cvgv && isGV(cvgv)) {
1841             SV * const sv = newSV(0);
1842             gv_efullname3(sv, cvgv, NULL);
1843             mPUSHs(sv);
1844             PUSHs(boolSV(CxHASARGS(cx)));
1845         }
1846         else {
1847             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1848             PUSHs(boolSV(CxHASARGS(cx)));
1849         }
1850     }
1851     else {
1852         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1853         mPUSHi(0);
1854     }
1855     gimme = (I32)cx->blk_gimme;
1856     if (gimme == G_VOID)
1857         PUSHs(&PL_sv_undef);
1858     else
1859         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1860     if (CxTYPE(cx) == CXt_EVAL) {
1861         /* eval STRING */
1862         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1863             SV *cur_text = cx->blk_eval.cur_text;
1864             if (SvCUR(cur_text) >= 2) {
1865                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1866                                      SvUTF8(cur_text)|SVs_TEMP));
1867             }
1868             else {
1869                 /* I think this is will always be "", but be sure */
1870                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1871             }
1872
1873             PUSHs(&PL_sv_no);
1874         }
1875         /* require */
1876         else if (cx->blk_eval.old_namesv) {
1877             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1878             PUSHs(&PL_sv_yes);
1879         }
1880         /* eval BLOCK (try blocks have old_namesv == 0) */
1881         else {
1882             PUSHs(&PL_sv_undef);
1883             PUSHs(&PL_sv_undef);
1884         }
1885     }
1886     else {
1887         PUSHs(&PL_sv_undef);
1888         PUSHs(&PL_sv_undef);
1889     }
1890     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1891         && CopSTASH_eq(PL_curcop, PL_debstash))
1892     {
1893         AV * const ary = cx->blk_sub.argarray;
1894         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1895
1896         Perl_init_dbargs(aTHX);
1897
1898         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1899             av_extend(PL_dbargs, AvFILLp(ary) + off);
1900         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1901         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1902     }
1903     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1904     {
1905         SV * mask ;
1906         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1907
1908         if  (old_warnings == pWARN_NONE)
1909             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1910         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1911             mask = &PL_sv_undef ;
1912         else if (old_warnings == pWARN_ALL ||
1913                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1914             /* Get the bit mask for $warnings::Bits{all}, because
1915              * it could have been extended by warnings::register */
1916             SV **bits_all;
1917             HV * const bits = get_hv("warnings::Bits", 0);
1918             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1919                 mask = newSVsv(*bits_all);
1920             }
1921             else {
1922                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1923             }
1924         }
1925         else
1926             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1927         mPUSHs(mask);
1928     }
1929
1930     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1931           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1932           : &PL_sv_undef);
1933     RETURN;
1934 }
1935
1936 PP(pp_reset)
1937 {
1938     dVAR;
1939     dSP;
1940     const char * tmps;
1941     STRLEN len = 0;
1942     if (MAXARG < 1 || (!TOPs && !POPs))
1943         tmps = NULL, len = 0;
1944     else
1945         tmps = SvPVx_const(POPs, len);
1946     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1947     PUSHs(&PL_sv_yes);
1948     RETURN;
1949 }
1950
1951 /* like pp_nextstate, but used instead when the debugger is active */
1952
1953 PP(pp_dbstate)
1954 {
1955     dVAR;
1956     PL_curcop = (COP*)PL_op;
1957     TAINT_NOT;          /* Each statement is presumed innocent */
1958     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1959     FREETMPS;
1960
1961     PERL_ASYNC_CHECK();
1962
1963     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1964             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1965     {
1966         dSP;
1967         PERL_CONTEXT *cx;
1968         const I32 gimme = G_ARRAY;
1969         U8 hasargs;
1970         GV * const gv = PL_DBgv;
1971         CV * cv = NULL;
1972
1973         if (gv && isGV_with_GP(gv))
1974             cv = GvCV(gv);
1975
1976         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1977             DIE(aTHX_ "No DB::DB routine defined");
1978
1979         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1980             /* don't do recursive DB::DB call */
1981             return NORMAL;
1982
1983         ENTER;
1984         SAVETMPS;
1985
1986         SAVEI32(PL_debug);
1987         SAVESTACK_POS();
1988         PL_debug = 0;
1989         hasargs = 0;
1990         SPAGAIN;
1991
1992         if (CvISXSUB(cv)) {
1993             PUSHMARK(SP);
1994             (void)(*CvXSUB(cv))(aTHX_ cv);
1995             FREETMPS;
1996             LEAVE;
1997             return NORMAL;
1998         }
1999         else {
2000             PUSHBLOCK(cx, CXt_SUB, SP);
2001             PUSHSUB_DB(cx);
2002             cx->blk_sub.retop = PL_op->op_next;
2003             CvDEPTH(cv)++;
2004             if (CvDEPTH(cv) >= 2) {
2005                 PERL_STACK_OVERFLOW_CHECK();
2006                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2007             }
2008             SAVECOMPPAD();
2009             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2010             RETURNOP(CvSTART(cv));
2011         }
2012     }
2013     else
2014         return NORMAL;
2015 }
2016
2017 /* SVs on the stack that have any of the flags passed in are left as is.
2018    Other SVs are protected via the mortals stack if lvalue is true, and
2019    copied otherwise. */
2020
2021 STATIC SV **
2022 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2023                               U32 flags, bool lvalue)
2024 {
2025     bool padtmp = 0;
2026     PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2027
2028     if (flags & SVs_PADTMP) {
2029         flags &= ~SVs_PADTMP;
2030         padtmp = 1;
2031     }
2032     if (gimme == G_SCALAR) {
2033         if (MARK < SP)
2034             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2035                             ? *SP
2036                             : lvalue
2037                                 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2038                                 : sv_mortalcopy(*SP);
2039         else {
2040             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2041             MARK = newsp;
2042             MEXTEND(MARK, 1);
2043             *++MARK = &PL_sv_undef;
2044             return MARK;
2045         }
2046     }
2047     else if (gimme == G_ARRAY) {
2048         /* in case LEAVE wipes old return values */
2049         while (++MARK <= SP) {
2050             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2051                 *++newsp = *MARK;
2052             else {
2053                 *++newsp = lvalue
2054                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2055                             : sv_mortalcopy(*MARK);
2056                 TAINT_NOT;      /* Each item is independent */
2057             }
2058         }
2059         /* When this function was called with MARK == newsp, we reach this
2060          * point with SP == newsp. */
2061     }
2062
2063     return newsp;
2064 }
2065
2066 PP(pp_enter)
2067 {
2068     dVAR; dSP;
2069     PERL_CONTEXT *cx;
2070     I32 gimme = GIMME_V;
2071
2072     ENTER_with_name("block");
2073
2074     SAVETMPS;
2075     PUSHBLOCK(cx, CXt_BLOCK, SP);
2076
2077     RETURN;
2078 }
2079
2080 PP(pp_leave)
2081 {
2082     dVAR; dSP;
2083     PERL_CONTEXT *cx;
2084     SV **newsp;
2085     PMOP *newpm;
2086     I32 gimme;
2087
2088     if (PL_op->op_flags & OPf_SPECIAL) {
2089         cx = &cxstack[cxstack_ix];
2090         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2091     }
2092
2093     POPBLOCK(cx,newpm);
2094
2095     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2096
2097     TAINT_NOT;
2098     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2099                                PL_op->op_private & OPpLVALUE);
2100     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2101
2102     LEAVE_with_name("block");
2103
2104     RETURN;
2105 }
2106
2107 PP(pp_enteriter)
2108 {
2109     dVAR; dSP; dMARK;
2110     PERL_CONTEXT *cx;
2111     const I32 gimme = GIMME_V;
2112     void *itervar; /* location of the iteration variable */
2113     U8 cxtype = CXt_LOOP_FOR;
2114
2115     ENTER_with_name("loop1");
2116     SAVETMPS;
2117
2118     if (PL_op->op_targ) {                        /* "my" variable */
2119         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2120             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2121             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2122                     SVs_PADSTALE, SVs_PADSTALE);
2123         }
2124         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2125 #ifdef USE_ITHREADS
2126         itervar = PL_comppad;
2127 #else
2128         itervar = &PAD_SVl(PL_op->op_targ);
2129 #endif
2130     }
2131     else {                                      /* symbol table variable */
2132         GV * const gv = MUTABLE_GV(POPs);
2133         SV** svp = &GvSV(gv);
2134         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2135         *svp = newSV(0);
2136         itervar = (void *)gv;
2137     }
2138
2139     if (PL_op->op_private & OPpITER_DEF)
2140         cxtype |= CXp_FOR_DEF;
2141
2142     ENTER_with_name("loop2");
2143
2144     PUSHBLOCK(cx, cxtype, SP);
2145     PUSHLOOP_FOR(cx, itervar, MARK);
2146     if (PL_op->op_flags & OPf_STACKED) {
2147         SV *maybe_ary = POPs;
2148         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2149             dPOPss;
2150             SV * const right = maybe_ary;
2151             SvGETMAGIC(sv);
2152             SvGETMAGIC(right);
2153             if (RANGE_IS_NUMERIC(sv,right)) {
2154                 cx->cx_type &= ~CXTYPEMASK;
2155                 cx->cx_type |= CXt_LOOP_LAZYIV;
2156                 /* Make sure that no-one re-orders cop.h and breaks our
2157                    assumptions */
2158                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2159 #ifdef NV_PRESERVES_UV
2160                 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2161                                   (SvNV_nomg(sv) > (NV)IV_MAX)))
2162                         ||
2163                     (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2164                                      (SvNV_nomg(right) < (NV)IV_MIN))))
2165 #else
2166                 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2167                                   ||
2168                                   ((SvNV_nomg(sv) > 0) &&
2169                                         ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2170                                          (SvNV_nomg(sv) > (NV)UV_MAX)))))
2171                         ||
2172                     (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2173                                      ||
2174                                      ((SvNV_nomg(right) > 0) &&
2175                                         ((SvUV_nomg(right) > (UV)IV_MAX) ||
2176                                          (SvNV_nomg(right) > (NV)UV_MAX))
2177                                      ))))
2178 #endif
2179                     DIE(aTHX_ "Range iterator outside integer range");
2180                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2181                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2182 #ifdef DEBUGGING
2183                 /* for correct -Dstv display */
2184                 cx->blk_oldsp = sp - PL_stack_base;
2185 #endif
2186             }
2187             else {
2188                 cx->cx_type &= ~CXTYPEMASK;
2189                 cx->cx_type |= CXt_LOOP_LAZYSV;
2190                 /* Make sure that no-one re-orders cop.h and breaks our
2191                    assumptions */
2192                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2193                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2194                 cx->blk_loop.state_u.lazysv.end = right;
2195                 SvREFCNT_inc(right);
2196                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2197                 /* This will do the upgrade to SVt_PV, and warn if the value
2198                    is uninitialised.  */
2199                 (void) SvPV_nolen_const(right);
2200                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2201                    to replace !SvOK() with a pointer to "".  */
2202                 if (!SvOK(right)) {
2203                     SvREFCNT_dec(right);
2204                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2205                 }
2206             }
2207         }
2208         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2209             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2210             SvREFCNT_inc(maybe_ary);
2211             cx->blk_loop.state_u.ary.ix =
2212                 (PL_op->op_private & OPpITER_REVERSED) ?
2213                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2214                 -1;
2215         }
2216     }
2217     else { /* iterating over items on the stack */
2218         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2219         if (PL_op->op_private & OPpITER_REVERSED) {
2220             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2221         }
2222         else {
2223             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2224         }
2225     }
2226
2227     RETURN;
2228 }
2229
2230 PP(pp_enterloop)
2231 {
2232     dVAR; dSP;
2233     PERL_CONTEXT *cx;
2234     const I32 gimme = GIMME_V;
2235
2236     ENTER_with_name("loop1");
2237     SAVETMPS;
2238     ENTER_with_name("loop2");
2239
2240     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2241     PUSHLOOP_PLAIN(cx, SP);
2242
2243     RETURN;
2244 }
2245
2246 PP(pp_leaveloop)
2247 {
2248     dVAR; dSP;
2249     PERL_CONTEXT *cx;
2250     I32 gimme;
2251     SV **newsp;
2252     PMOP *newpm;
2253     SV **mark;
2254
2255     POPBLOCK(cx,newpm);
2256     assert(CxTYPE_is_LOOP(cx));
2257     mark = newsp;
2258     newsp = PL_stack_base + cx->blk_loop.resetsp;
2259
2260     TAINT_NOT;
2261     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0,
2262                                PL_op->op_private & OPpLVALUE);
2263     PUTBACK;
2264
2265     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2266     PL_curpm = newpm;   /* ... and pop $1 et al */
2267
2268     LEAVE_with_name("loop2");
2269     LEAVE_with_name("loop1");
2270
2271     return NORMAL;
2272 }
2273
2274 STATIC void
2275 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2276                        PERL_CONTEXT *cx, PMOP *newpm)
2277 {
2278     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2279     if (gimme == G_SCALAR) {
2280         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2281             SV *sv;
2282             const char *what = NULL;
2283             if (MARK < SP) {
2284                 assert(MARK+1 == SP);
2285                 if ((SvPADTMP(TOPs) ||
2286                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2287                        == SVf_READONLY
2288                     ) &&
2289                     !SvSMAGICAL(TOPs)) {
2290                     what =
2291                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2292                         : "a readonly value" : "a temporary";
2293                 }
2294                 else goto copy_sv;
2295             }
2296             else {
2297                 /* sub:lvalue{} will take us here. */
2298                 what = "undef";
2299             }
2300             LEAVE;
2301             cxstack_ix--;
2302             POPSUB(cx,sv);
2303             PL_curpm = newpm;
2304             LEAVESUB(sv);
2305             Perl_croak(aTHX_
2306                       "Can't return %s from lvalue subroutine", what
2307             );
2308         }
2309         if (MARK < SP) {
2310               copy_sv:
2311                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2312                     if (!SvPADTMP(*SP)) {
2313                         *++newsp = SvREFCNT_inc(*SP);
2314                         FREETMPS;
2315                         sv_2mortal(*newsp);
2316                     }
2317                     else {
2318                         /* FREETMPS could clobber it */
2319                         SV *sv = SvREFCNT_inc(*SP);
2320                         FREETMPS;
2321                         *++newsp = sv_mortalcopy(sv);
2322                         SvREFCNT_dec(sv);
2323                     }
2324                 }
2325                 else
2326                     *++newsp =
2327                       SvPADTMP(*SP)
2328                        ? sv_mortalcopy(*SP)
2329                        : !SvTEMP(*SP)
2330                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2331                           : *SP;
2332         }
2333         else {
2334             EXTEND(newsp,1);
2335             *++newsp = &PL_sv_undef;
2336         }
2337         if (CxLVAL(cx) & OPpDEREF) {
2338             SvGETMAGIC(TOPs);
2339             if (!SvOK(TOPs)) {
2340                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2341             }
2342         }
2343     }
2344     else if (gimme == G_ARRAY) {
2345         assert (!(CxLVAL(cx) & OPpDEREF));
2346         if (ref || !CxLVAL(cx))
2347             while (++MARK <= SP)
2348                 *++newsp =
2349                        SvFLAGS(*MARK) & SVs_PADTMP
2350                            ? sv_mortalcopy(*MARK)
2351                      : SvTEMP(*MARK)
2352                            ? *MARK
2353                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2354         else while (++MARK <= SP) {
2355             if (*MARK != &PL_sv_undef
2356                     && (SvPADTMP(*MARK)
2357                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2358                              == SVf_READONLY
2359                        )
2360             ) {
2361                     SV *sv;
2362                     /* Might be flattened array after $#array =  */
2363                     PUTBACK;
2364                     LEAVE;
2365                     cxstack_ix--;
2366                     POPSUB(cx,sv);
2367                     PL_curpm = newpm;
2368                     LEAVESUB(sv);
2369                /* diag_listed_as: Can't return %s from lvalue subroutine */
2370                     Perl_croak(aTHX_
2371                         "Can't return a %s from lvalue subroutine",
2372                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2373             }
2374             else
2375                 *++newsp =
2376                     SvTEMP(*MARK)
2377                        ? *MARK
2378                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2379         }
2380     }
2381     PL_stack_sp = newsp;
2382 }
2383
2384 PP(pp_return)
2385 {
2386     dVAR; dSP; dMARK;
2387     PERL_CONTEXT *cx;
2388     bool popsub2 = FALSE;
2389     bool clear_errsv = FALSE;
2390     bool lval = FALSE;
2391     I32 gimme;
2392     SV **newsp;
2393     PMOP *newpm;
2394     I32 optype = 0;
2395     SV *namesv;
2396     SV *sv;
2397     OP *retop = NULL;
2398
2399     const I32 cxix = dopoptosub(cxstack_ix);
2400
2401     if (cxix < 0) {
2402         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2403                                      * sort block, which is a CXt_NULL
2404                                      * not a CXt_SUB */
2405             dounwind(0);
2406             PL_stack_base[1] = *PL_stack_sp;
2407             PL_stack_sp = PL_stack_base + 1;
2408             return 0;
2409         }
2410         else
2411             DIE(aTHX_ "Can't return outside a subroutine");
2412     }
2413     if (cxix < cxstack_ix)
2414         dounwind(cxix);
2415
2416     if (CxMULTICALL(&cxstack[cxix])) {
2417         gimme = cxstack[cxix].blk_gimme;
2418         if (gimme == G_VOID)
2419             PL_stack_sp = PL_stack_base;
2420         else if (gimme == G_SCALAR) {
2421             PL_stack_base[1] = *PL_stack_sp;
2422             PL_stack_sp = PL_stack_base + 1;
2423         }
2424         return 0;
2425     }
2426
2427     POPBLOCK(cx,newpm);
2428     switch (CxTYPE(cx)) {
2429     case CXt_SUB:
2430         popsub2 = TRUE;
2431         lval = !!CvLVALUE(cx->blk_sub.cv);
2432         retop = cx->blk_sub.retop;
2433         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2434         break;
2435     case CXt_EVAL:
2436         if (!(PL_in_eval & EVAL_KEEPERR))
2437             clear_errsv = TRUE;
2438         POPEVAL(cx);
2439         namesv = cx->blk_eval.old_namesv;
2440         retop = cx->blk_eval.retop;
2441         if (CxTRYBLOCK(cx))
2442             break;
2443         if (optype == OP_REQUIRE &&
2444             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2445         {
2446             /* Unassume the success we assumed earlier. */
2447             (void)hv_delete(GvHVn(PL_incgv),
2448                             SvPVX_const(namesv),
2449                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2450                             G_DISCARD);
2451             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2452         }
2453         break;
2454     case CXt_FORMAT:
2455         retop = cx->blk_sub.retop;
2456         POPFORMAT(cx);
2457         break;
2458     default:
2459         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2460     }
2461
2462     TAINT_NOT;
2463     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2464     else {
2465       if (gimme == G_SCALAR) {
2466         if (MARK < SP) {
2467             if (popsub2) {
2468                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2469                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2470                          && !SvMAGICAL(TOPs)) {
2471                         *++newsp = SvREFCNT_inc(*SP);
2472                         FREETMPS;
2473                         sv_2mortal(*newsp);
2474                     }
2475                     else {
2476                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2477                         FREETMPS;
2478                         *++newsp = sv_mortalcopy(sv);
2479                         SvREFCNT_dec(sv);
2480                     }
2481                 }
2482                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2483                           && !SvMAGICAL(*SP)) {
2484                     *++newsp = *SP;
2485                 }
2486                 else
2487                     *++newsp = sv_mortalcopy(*SP);
2488             }
2489             else
2490                 *++newsp = sv_mortalcopy(*SP);
2491         }
2492         else
2493             *++newsp = &PL_sv_undef;
2494       }
2495       else if (gimme == G_ARRAY) {
2496         while (++MARK <= SP) {
2497             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2498                                && !SvGMAGICAL(*MARK)
2499                         ? *MARK : sv_mortalcopy(*MARK);
2500             TAINT_NOT;          /* Each item is independent */
2501         }
2502       }
2503       PL_stack_sp = newsp;
2504     }
2505
2506     LEAVE;
2507     /* Stack values are safe: */
2508     if (popsub2) {
2509         cxstack_ix--;
2510         POPSUB(cx,sv);  /* release CV and @_ ... */
2511     }
2512     else
2513         sv = NULL;
2514     PL_curpm = newpm;   /* ... and pop $1 et al */
2515
2516     LEAVESUB(sv);
2517     if (clear_errsv) {
2518         CLEAR_ERRSV();
2519     }
2520     return retop;
2521 }
2522
2523 /* This duplicates parts of pp_leavesub, so that it can share code with
2524  * pp_return */
2525 PP(pp_leavesublv)
2526 {
2527     dVAR; dSP;
2528     SV **newsp;
2529     PMOP *newpm;
2530     I32 gimme;
2531     PERL_CONTEXT *cx;
2532     SV *sv;
2533
2534     if (CxMULTICALL(&cxstack[cxstack_ix]))
2535         return 0;
2536
2537     POPBLOCK(cx,newpm);
2538     cxstack_ix++; /* temporarily protect top context */
2539
2540     TAINT_NOT;
2541
2542     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2543
2544     LEAVE;
2545     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2546     cxstack_ix--;
2547     PL_curpm = newpm;   /* ... and pop $1 et al */
2548
2549     LEAVESUB(sv);
2550     return cx->blk_sub.retop;
2551 }
2552
2553 static I32
2554 S_unwind_loop(pTHX_ const char * const opname)
2555 {
2556     dVAR;
2557     I32 cxix;
2558     if (PL_op->op_flags & OPf_SPECIAL) {
2559         cxix = dopoptoloop(cxstack_ix);
2560         if (cxix < 0)
2561             /* diag_listed_as: Can't "last" outside a loop block */
2562             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2563     }
2564     else {
2565         dSP;
2566         STRLEN label_len;
2567         const char * const label =
2568             PL_op->op_flags & OPf_STACKED
2569                 ? SvPV(TOPs,label_len)
2570                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2571         const U32 label_flags =
2572             PL_op->op_flags & OPf_STACKED
2573                 ? SvUTF8(POPs)
2574                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2575         PUTBACK;
2576         cxix = dopoptolabel(label, label_len, label_flags);
2577         if (cxix < 0)
2578             /* diag_listed_as: Label not found for "last %s" */
2579             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2580                                        opname,
2581                                        SVfARG(PL_op->op_flags & OPf_STACKED
2582                                               && !SvGMAGICAL(TOPp1s)
2583                                               ? TOPp1s
2584                                               : newSVpvn_flags(label,
2585                                                     label_len,
2586                                                     label_flags | SVs_TEMP)));
2587     }
2588     if (cxix < cxstack_ix)
2589         dounwind(cxix);
2590     return cxix;
2591 }
2592
2593 PP(pp_last)
2594 {
2595     dVAR;
2596     PERL_CONTEXT *cx;
2597     I32 pop2 = 0;
2598     I32 gimme;
2599     I32 optype;
2600     OP *nextop = NULL;
2601     SV **newsp;
2602     PMOP *newpm;
2603     SV *sv = NULL;
2604
2605     S_unwind_loop(aTHX_ "last");
2606
2607     POPBLOCK(cx,newpm);
2608     cxstack_ix++; /* temporarily protect top context */
2609     switch (CxTYPE(cx)) {
2610     case CXt_LOOP_LAZYIV:
2611     case CXt_LOOP_LAZYSV:
2612     case CXt_LOOP_FOR:
2613     case CXt_LOOP_PLAIN:
2614         pop2 = CxTYPE(cx);
2615         newsp = PL_stack_base + cx->blk_loop.resetsp;
2616         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2617         break;
2618     case CXt_SUB:
2619         pop2 = CXt_SUB;
2620         nextop = cx->blk_sub.retop;
2621         break;
2622     case CXt_EVAL:
2623         POPEVAL(cx);
2624         nextop = cx->blk_eval.retop;
2625         break;
2626     case CXt_FORMAT:
2627         POPFORMAT(cx);
2628         nextop = cx->blk_sub.retop;
2629         break;
2630     default:
2631         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2632     }
2633
2634     TAINT_NOT;
2635     PL_stack_sp = newsp;
2636
2637     LEAVE;
2638     cxstack_ix--;
2639     /* Stack values are safe: */
2640     switch (pop2) {
2641     case CXt_LOOP_LAZYIV:
2642     case CXt_LOOP_PLAIN:
2643     case CXt_LOOP_LAZYSV:
2644     case CXt_LOOP_FOR:
2645         POPLOOP(cx);    /* release loop vars ... */
2646         LEAVE;
2647         break;
2648     case CXt_SUB:
2649         POPSUB(cx,sv);  /* release CV and @_ ... */
2650         break;
2651     }
2652     PL_curpm = newpm;   /* ... and pop $1 et al */
2653
2654     LEAVESUB(sv);
2655     PERL_UNUSED_VAR(optype);
2656     PERL_UNUSED_VAR(gimme);
2657     return nextop;
2658 }
2659
2660 PP(pp_next)
2661 {
2662     dVAR;
2663     PERL_CONTEXT *cx;
2664     const I32 inner = PL_scopestack_ix;
2665
2666     S_unwind_loop(aTHX_ "next");
2667
2668     /* clear off anything above the scope we're re-entering, but
2669      * save the rest until after a possible continue block */
2670     TOPBLOCK(cx);
2671     if (PL_scopestack_ix < inner)
2672         leave_scope(PL_scopestack[PL_scopestack_ix]);
2673     PL_curcop = cx->blk_oldcop;
2674     PERL_ASYNC_CHECK();
2675     return (cx)->blk_loop.my_op->op_nextop;
2676 }
2677
2678 PP(pp_redo)
2679 {
2680     dVAR;
2681     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2682     PERL_CONTEXT *cx;
2683     I32 oldsave;
2684     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2685
2686     if (redo_op->op_type == OP_ENTER) {
2687         /* pop one less context to avoid $x being freed in while (my $x..) */
2688         cxstack_ix++;
2689         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2690         redo_op = redo_op->op_next;
2691     }
2692
2693     TOPBLOCK(cx);
2694     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2695     LEAVE_SCOPE(oldsave);
2696     FREETMPS;
2697     PL_curcop = cx->blk_oldcop;
2698     PERL_ASYNC_CHECK();
2699     return redo_op;
2700 }
2701
2702 STATIC OP *
2703 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2704 {
2705     dVAR;
2706     OP **ops = opstack;
2707     static const char* const too_deep = "Target of goto is too deeply nested";
2708
2709     PERL_ARGS_ASSERT_DOFINDLABEL;
2710
2711     if (ops >= oplimit)
2712         Perl_croak(aTHX_ "%s", too_deep);
2713     if (o->op_type == OP_LEAVE ||
2714         o->op_type == OP_SCOPE ||
2715         o->op_type == OP_LEAVELOOP ||
2716         o->op_type == OP_LEAVESUB ||
2717         o->op_type == OP_LEAVETRY)
2718     {
2719         *ops++ = cUNOPo->op_first;
2720         if (ops >= oplimit)
2721             Perl_croak(aTHX_ "%s", too_deep);
2722     }
2723     *ops = 0;
2724     if (o->op_flags & OPf_KIDS) {
2725         OP *kid;
2726         /* First try all the kids at this level, since that's likeliest. */
2727         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2728             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2729                 STRLEN kid_label_len;
2730                 U32 kid_label_flags;
2731                 const char *kid_label = CopLABEL_len_flags(kCOP,
2732                                                     &kid_label_len, &kid_label_flags);
2733                 if (kid_label && (
2734                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2735                         (flags & SVf_UTF8)
2736                             ? (bytes_cmp_utf8(
2737                                         (const U8*)kid_label, kid_label_len,
2738                                         (const U8*)label, len) == 0)
2739                             : (bytes_cmp_utf8(
2740                                         (const U8*)label, len,
2741                                         (const U8*)kid_label, kid_label_len) == 0)
2742                     : ( len == kid_label_len && ((kid_label == label)
2743                                     || memEQ(kid_label, label, len)))))
2744                     return kid;
2745             }
2746         }
2747         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2748             if (kid == PL_lastgotoprobe)
2749                 continue;
2750             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2751                 if (ops == opstack)
2752                     *ops++ = kid;
2753                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2754                          ops[-1]->op_type == OP_DBSTATE)
2755                     ops[-1] = kid;
2756                 else
2757                     *ops++ = kid;
2758             }
2759             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2760                 return o;
2761         }
2762     }
2763     *ops = 0;
2764     return 0;
2765 }
2766
2767 PP(pp_goto) /* also pp_dump */
2768 {
2769     dVAR; dSP;
2770     OP *retop = NULL;
2771     I32 ix;
2772     PERL_CONTEXT *cx;
2773 #define GOTO_DEPTH 64
2774     OP *enterops[GOTO_DEPTH];
2775     const char *label = NULL;
2776     STRLEN label_len = 0;
2777     U32 label_flags = 0;
2778     const bool do_dump = (PL_op->op_type == OP_DUMP);
2779     static const char* const must_have_label = "goto must have label";
2780
2781     if (PL_op->op_flags & OPf_STACKED) {
2782         /* goto EXPR  or  goto &foo */
2783
2784         SV * const sv = POPs;
2785         SvGETMAGIC(sv);
2786
2787         /* This egregious kludge implements goto &subroutine */
2788         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2789             I32 cxix;
2790             PERL_CONTEXT *cx;
2791             CV *cv = MUTABLE_CV(SvRV(sv));
2792             AV *arg = GvAV(PL_defgv);
2793             I32 oldsave;
2794
2795         retry:
2796             if (!CvROOT(cv) && !CvXSUB(cv)) {
2797                 const GV * const gv = CvGV(cv);
2798                 if (gv) {
2799                     GV *autogv;
2800                     SV *tmpstr;
2801                     /* autoloaded stub? */
2802                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2803                         goto retry;
2804                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2805                                           GvNAMELEN(gv),
2806                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2807                     if (autogv && (cv = GvCV(autogv)))
2808                         goto retry;
2809                     tmpstr = sv_newmortal();
2810                     gv_efullname3(tmpstr, gv, NULL);
2811                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2812                 }
2813                 DIE(aTHX_ "Goto undefined subroutine");
2814             }
2815
2816             /* First do some returnish stuff. */
2817             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2818             FREETMPS;
2819             cxix = dopoptosub(cxstack_ix);
2820             if (cxix < cxstack_ix) {
2821                 if (cxix < 0) {
2822                     SvREFCNT_dec(cv);
2823                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2824                 }
2825                 dounwind(cxix);
2826             }
2827             TOPBLOCK(cx);
2828             SPAGAIN;
2829             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2830             if (CxTYPE(cx) == CXt_EVAL) {
2831                 SvREFCNT_dec(cv);
2832                 if (CxREALEVAL(cx))
2833                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2834                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2835                 else
2836                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2837                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2838             }
2839             else if (CxMULTICALL(cx))
2840             {
2841                 SvREFCNT_dec(cv);
2842                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2843             }
2844             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2845                 AV* av = cx->blk_sub.argarray;
2846
2847                 /* abandon the original @_ if it got reified or if it is
2848                    the same as the current @_ */
2849                 if (AvREAL(av) || av == arg) {
2850                     SvREFCNT_dec(av);
2851                     av = newAV();
2852                     AvREIFY_only(av);
2853                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2854                 }
2855                 else CLEAR_ARGARRAY(av);
2856             }
2857             /* We donate this refcount later to the callee’s pad. */
2858             SvREFCNT_inc_simple_void(arg);
2859             if (CxTYPE(cx) == CXt_SUB &&
2860                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2861                 SvREFCNT_dec(cx->blk_sub.cv);
2862             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2863             LEAVE_SCOPE(oldsave);
2864
2865             /* A destructor called during LEAVE_SCOPE could have undefined
2866              * our precious cv.  See bug #99850. */
2867             if (!CvROOT(cv) && !CvXSUB(cv)) {
2868                 const GV * const gv = CvGV(cv);
2869                 SvREFCNT_dec(arg);
2870                 if (gv) {
2871                     SV * const tmpstr = sv_newmortal();
2872                     gv_efullname3(tmpstr, gv, NULL);
2873                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2874                                SVfARG(tmpstr));
2875                 }
2876                 DIE(aTHX_ "Goto undefined subroutine");
2877             }
2878
2879             /* Now do some callish stuff. */
2880             SAVETMPS;
2881             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2882             if (CvISXSUB(cv)) {
2883                 OP* const retop = cx->blk_sub.retop;
2884                 SV **newsp;
2885                 I32 gimme;
2886                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2887                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2888                 SV** mark;
2889
2890                 PERL_UNUSED_VAR(newsp);
2891                 PERL_UNUSED_VAR(gimme);
2892
2893                 /* put GvAV(defgv) back onto stack */
2894                 if (items) {
2895                     EXTEND(SP, items+1); /* @_ could have been extended. */
2896                 }
2897                 mark = SP;
2898                 if (items) {
2899                     SSize_t index;
2900                     bool r = cBOOL(AvREAL(arg));
2901                     for (index=0; index<items; index++)
2902                     {
2903                         SV *sv;
2904                         if (m) {
2905                             SV ** const svp = av_fetch(arg, index, 0);
2906                             sv = svp ? *svp : NULL;
2907                         }
2908                         else sv = AvARRAY(arg)[index];
2909                         SP[index+1] = sv
2910                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2911                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2912                     }
2913                 }
2914                 SP += items;
2915                 SvREFCNT_dec(arg);
2916                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2917                     /* Restore old @_ */
2918                     arg = GvAV(PL_defgv);
2919                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2920                     SvREFCNT_dec(arg);
2921                 }
2922
2923                 /* XS subs don't have a CxSUB, so pop it */
2924                 POPBLOCK(cx, PL_curpm);
2925                 /* Push a mark for the start of arglist */
2926                 PUSHMARK(mark);
2927                 PUTBACK;
2928                 (void)(*CvXSUB(cv))(aTHX_ cv);
2929                 LEAVE;
2930                 PERL_ASYNC_CHECK();
2931                 return retop;
2932             }
2933             else {
2934                 PADLIST * const padlist = CvPADLIST(cv);
2935                 cx->blk_sub.cv = cv;
2936                 cx->blk_sub.olddepth = CvDEPTH(cv);
2937
2938                 CvDEPTH(cv)++;
2939                 if (CvDEPTH(cv) < 2)
2940                     SvREFCNT_inc_simple_void_NN(cv);
2941                 else {
2942                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2943                         sub_crush_depth(cv);
2944                     pad_push(padlist, CvDEPTH(cv));
2945                 }
2946                 PL_curcop = cx->blk_oldcop;
2947                 SAVECOMPPAD();
2948                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2949                 if (CxHASARGS(cx))
2950                 {
2951                     CX_CURPAD_SAVE(cx->blk_sub);
2952
2953                     /* cx->blk_sub.argarray has no reference count, so we
2954                        need something to hang on to our argument array so
2955                        that cx->blk_sub.argarray does not end up pointing
2956                        to freed memory as the result of undef *_.  So put
2957                        it in the callee’s pad, donating our refer-
2958                        ence count. */
2959                     if (arg) {
2960                         SvREFCNT_dec(PAD_SVl(0));
2961                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2962                     }
2963
2964                     /* GvAV(PL_defgv) might have been modified on scope
2965                        exit, so restore it. */
2966                     if (arg != GvAV(PL_defgv)) {
2967                         AV * const av = GvAV(PL_defgv);
2968                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2969                         SvREFCNT_dec(av);
2970                     }
2971                 }
2972                 else SvREFCNT_dec(arg);
2973                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2974                     Perl_get_db_sub(aTHX_ NULL, cv);
2975                     if (PERLDB_GOTO) {
2976                         CV * const gotocv = get_cvs("DB::goto", 0);
2977                         if (gotocv) {
2978                             PUSHMARK( PL_stack_sp );
2979                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2980                             PL_stack_sp--;
2981                         }
2982                     }
2983                 }
2984                 PERL_ASYNC_CHECK();
2985                 RETURNOP(CvSTART(cv));
2986             }
2987         }
2988         else {
2989             /* goto EXPR */
2990             label       = SvPV_nomg_const(sv, label_len);
2991             label_flags = SvUTF8(sv);
2992         }
2993     }
2994     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2995         /* goto LABEL  or  dump LABEL */
2996         label       = cPVOP->op_pv;
2997         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2998         label_len   = strlen(label);
2999     }
3000     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3001
3002     PERL_ASYNC_CHECK();
3003
3004     if (label_len) {
3005         OP *gotoprobe = NULL;
3006         bool leaving_eval = FALSE;
3007         bool in_block = FALSE;
3008         PERL_CONTEXT *last_eval_cx = NULL;
3009
3010         /* find label */
3011
3012         PL_lastgotoprobe = NULL;
3013         *enterops = 0;
3014         for (ix = cxstack_ix; ix >= 0; ix--) {
3015             cx = &cxstack[ix];
3016             switch (CxTYPE(cx)) {
3017             case CXt_EVAL:
3018                 leaving_eval = TRUE;
3019                 if (!CxTRYBLOCK(cx)) {
3020                     gotoprobe = (last_eval_cx ?
3021                                 last_eval_cx->blk_eval.old_eval_root :
3022                                 PL_eval_root);
3023                     last_eval_cx = cx;
3024                     break;
3025                 }
3026                 /* else fall through */
3027             case CXt_LOOP_LAZYIV:
3028             case CXt_LOOP_LAZYSV:
3029             case CXt_LOOP_FOR:
3030             case CXt_LOOP_PLAIN:
3031             case CXt_GIVEN:
3032             case CXt_WHEN:
3033                 gotoprobe = cx->blk_oldcop->op_sibling;
3034                 break;
3035             case CXt_SUBST:
3036                 continue;
3037             case CXt_BLOCK:
3038                 if (ix) {
3039                     gotoprobe = cx->blk_oldcop->op_sibling;
3040                     in_block = TRUE;
3041                 } else
3042                     gotoprobe = PL_main_root;
3043                 break;
3044             case CXt_SUB:
3045                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3046                     gotoprobe = CvROOT(cx->blk_sub.cv);
3047                     break;
3048                 }
3049                 /* FALLTHROUGH */
3050             case CXt_FORMAT:
3051             case CXt_NULL:
3052                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3053             default:
3054                 if (ix)
3055                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3056                         CxTYPE(cx), (long) ix);
3057                 gotoprobe = PL_main_root;
3058                 break;
3059             }
3060             if (gotoprobe) {
3061                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3062                                     enterops, enterops + GOTO_DEPTH);
3063                 if (retop)
3064                     break;
3065                 if (gotoprobe->op_sibling &&
3066                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3067                         gotoprobe->op_sibling->op_sibling) {
3068                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3069                                         label, label_len, label_flags, enterops,
3070                                         enterops + GOTO_DEPTH);
3071                     if (retop)
3072                         break;
3073                 }
3074             }
3075             PL_lastgotoprobe = gotoprobe;
3076         }
3077         if (!retop)
3078             DIE(aTHX_ "Can't find label %"UTF8f,
3079                        UTF8fARG(label_flags, label_len, label));
3080
3081         /* if we're leaving an eval, check before we pop any frames
3082            that we're not going to punt, otherwise the error
3083            won't be caught */
3084
3085         if (leaving_eval && *enterops && enterops[1]) {
3086             I32 i;
3087             for (i = 1; enterops[i]; i++)
3088                 if (enterops[i]->op_type == OP_ENTERITER)
3089                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3090         }
3091
3092         if (*enterops && enterops[1]) {
3093             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3094             if (enterops[i])
3095                 deprecate("\"goto\" to jump into a construct");
3096         }
3097
3098         /* pop unwanted frames */
3099
3100         if (ix < cxstack_ix) {
3101             I32 oldsave;
3102
3103             if (ix < 0)
3104                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3105             dounwind(ix);
3106             TOPBLOCK(cx);
3107             oldsave = PL_scopestack[PL_scopestack_ix];
3108             LEAVE_SCOPE(oldsave);
3109         }
3110
3111         /* push wanted frames */
3112
3113         if (*enterops && enterops[1]) {
3114             OP * const oldop = PL_op;
3115             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3116             for (; enterops[ix]; ix++) {
3117                 PL_op = enterops[ix];
3118                 /* Eventually we may want to stack the needed arguments
3119                  * for each op.  For now, we punt on the hard ones. */
3120                 if (PL_op->op_type == OP_ENTERITER)
3121                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3122                 PL_op->op_ppaddr(aTHX);
3123             }
3124             PL_op = oldop;
3125         }
3126     }
3127
3128     if (do_dump) {
3129 #ifdef VMS
3130         if (!retop) retop = PL_main_start;
3131 #endif
3132         PL_restartop = retop;
3133         PL_do_undump = TRUE;
3134
3135         my_unexec();
3136
3137         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3138         PL_do_undump = FALSE;
3139     }
3140
3141     PERL_ASYNC_CHECK();
3142     RETURNOP(retop);
3143 }
3144
3145 PP(pp_exit)
3146 {
3147     dVAR;
3148     dSP;
3149     I32 anum;
3150
3151     if (MAXARG < 1)
3152         anum = 0;
3153     else if (!TOPs) {
3154         anum = 0; (void)POPs;
3155     }
3156     else {
3157         anum = SvIVx(POPs);
3158 #ifdef VMS
3159         if (anum == 1
3160          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3161             anum = 0;
3162         VMSISH_HUSHED  =
3163             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3164 #endif
3165     }
3166     PL_exit_flags |= PERL_EXIT_EXPECTED;
3167     my_exit(anum);
3168     PUSHs(&PL_sv_undef);
3169     RETURN;
3170 }
3171
3172 /* Eval. */
3173
3174 STATIC void
3175 S_save_lines(pTHX_ AV *array, SV *sv)
3176 {
3177     const char *s = SvPVX_const(sv);
3178     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3179     I32 line = 1;
3180
3181     PERL_ARGS_ASSERT_SAVE_LINES;
3182
3183     while (s && s < send) {
3184         const char *t;
3185         SV * const tmpstr = newSV_type(SVt_PVMG);
3186
3187         t = (const char *)memchr(s, '\n', send - s);
3188         if (t)
3189             t++;
3190         else
3191             t = send;
3192
3193         sv_setpvn(tmpstr, s, t - s);
3194         av_store(array, line++, tmpstr);
3195         s = t;
3196     }
3197 }
3198
3199 /*
3200 =for apidoc docatch
3201
3202 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3203
3204 0 is used as continue inside eval,
3205
3206 3 is used for a die caught by an inner eval - continue inner loop
3207
3208 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3209 establish a local jmpenv to handle exception traps.
3210
3211 =cut
3212 */
3213 STATIC OP *
3214 S_docatch(pTHX_ OP *o)
3215 {
3216     dVAR;
3217     int ret;
3218     OP * const oldop = PL_op;
3219     dJMPENV;
3220
3221 #ifdef DEBUGGING
3222     assert(CATCH_GET == TRUE);
3223 #endif
3224     PL_op = o;
3225
3226     JMPENV_PUSH(ret);
3227     switch (ret) {
3228     case 0:
3229         assert(cxstack_ix >= 0);
3230         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3231         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3232  redo_body:
3233         CALLRUNOPS(aTHX);
3234         break;
3235     case 3:
3236         /* die caught by an inner eval - continue inner loop */
3237         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3238             PL_restartjmpenv = NULL;
3239             PL_op = PL_restartop;
3240             PL_restartop = 0;
3241             goto redo_body;
3242         }
3243         /* FALLTHROUGH */
3244     default:
3245         JMPENV_POP;
3246         PL_op = oldop;
3247         JMPENV_JUMP(ret);
3248         assert(0); /* NOTREACHED */
3249     }
3250     JMPENV_POP;
3251     PL_op = oldop;
3252     return NULL;
3253 }
3254
3255
3256 /*
3257 =for apidoc find_runcv
3258
3259 Locate the CV corresponding to the currently executing sub or eval.
3260 If db_seqp is non_null, skip CVs that are in the DB package and populate
3261 *db_seqp with the cop sequence number at the point that the DB:: code was
3262 entered.  (This allows debuggers to eval in the scope of the breakpoint
3263 rather than in the scope of the debugger itself.)
3264
3265 =cut
3266 */
3267
3268 CV*
3269 Perl_find_runcv(pTHX_ U32 *db_seqp)
3270 {
3271     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3272 }
3273
3274 /* If this becomes part of the API, it might need a better name. */
3275 CV *
3276 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3277 {
3278     dVAR;
3279     PERL_SI      *si;
3280     int          level = 0;
3281
3282     if (db_seqp)
3283         *db_seqp =
3284             PL_curcop == &PL_compiling
3285                 ? PL_cop_seqmax
3286                 : PL_curcop->cop_seq;
3287
3288     for (si = PL_curstackinfo; si; si = si->si_prev) {
3289         I32 ix;
3290         for (ix = si->si_cxix; ix >= 0; ix--) {
3291             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3292             CV *cv = NULL;
3293             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3294                 cv = cx->blk_sub.cv;
3295                 /* skip DB:: code */
3296                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3297                     *db_seqp = cx->blk_oldcop->cop_seq;
3298                     continue;
3299                 }
3300                 if (cx->cx_type & CXp_SUB_RE)
3301                     continue;
3302             }
3303             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3304                 cv = cx->blk_eval.cv;
3305             if (cv) {
3306                 switch (cond) {
3307                 case FIND_RUNCV_padid_eq:
3308                     if (!CvPADLIST(cv)
3309                      || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3310                         continue;
3311                     return cv;
3312                 case FIND_RUNCV_level_eq:
3313                     if (level++ != arg) continue;
3314                     /* GERONIMO! */
3315                 default:
3316                     return cv;
3317                 }
3318             }
3319         }
3320     }
3321     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3322 }
3323
3324
3325 /* Run yyparse() in a setjmp wrapper. Returns:
3326  *   0: yyparse() successful
3327  *   1: yyparse() failed
3328  *   3: yyparse() died
3329  */
3330 STATIC int
3331 S_try_yyparse(pTHX_ int gramtype)
3332 {
3333     int ret;
3334     dJMPENV;
3335
3336     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3337     JMPENV_PUSH(ret);
3338     switch (ret) {
3339     case 0:
3340         ret = yyparse(gramtype) ? 1 : 0;
3341         break;
3342     case 3:
3343         break;
3344     default:
3345         JMPENV_POP;
3346         JMPENV_JUMP(ret);
3347         assert(0); /* NOTREACHED */
3348     }
3349     JMPENV_POP;
3350     return ret;
3351 }
3352
3353
3354 /* Compile a require/do or an eval ''.
3355  *
3356  * outside is the lexically enclosing CV (if any) that invoked us.
3357  * seq     is the current COP scope value.
3358  * hh      is the saved hints hash, if any.
3359  *
3360  * Returns a bool indicating whether the compile was successful; if so,
3361  * PL_eval_start contains the first op of the compiled code; otherwise,
3362  * pushes undef.
3363  *
3364  * This function is called from two places: pp_require and pp_entereval.
3365  * These can be distinguished by whether PL_op is entereval.
3366  */
3367
3368 STATIC bool
3369 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3370 {
3371     dVAR; dSP;
3372     OP * const saveop = PL_op;
3373     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3374     COP * const oldcurcop = PL_curcop;
3375     bool in_require = (saveop->op_type == OP_REQUIRE);
3376     int yystatus;
3377     CV *evalcv;
3378
3379     PL_in_eval = (in_require
3380                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3381                   : (EVAL_INEVAL |
3382                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3383                             ? EVAL_RE_REPARSING : 0)));
3384
3385     PUSHMARK(SP);
3386
3387     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3388     CvEVAL_on(evalcv);
3389     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3390     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3391     cxstack[cxstack_ix].blk_gimme = gimme;
3392
3393     CvOUTSIDE_SEQ(evalcv) = seq;
3394     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3395
3396     /* set up a scratch pad */
3397
3398     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3399     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3400
3401
3402     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3403
3404     /* make sure we compile in the right package */
3405
3406     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3407         SAVEGENERICSV(PL_curstash);
3408         PL_curstash = (HV *)CopSTASH(PL_curcop);
3409         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3410         else SvREFCNT_inc_simple_void(PL_curstash);
3411     }
3412     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3413     SAVESPTR(PL_beginav);
3414     PL_beginav = newAV();
3415     SAVEFREESV(PL_beginav);
3416     SAVESPTR(PL_unitcheckav);
3417     PL_unitcheckav = newAV();
3418     SAVEFREESV(PL_unitcheckav);
3419
3420
3421     ENTER_with_name("evalcomp");
3422     SAVESPTR(PL_compcv);
3423     PL_compcv = evalcv;
3424
3425     /* try to compile it */
3426
3427     PL_eval_root = NULL;
3428     PL_curcop = &PL_compiling;
3429     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3430         PL_in_eval |= EVAL_KEEPERR;
3431     else
3432         CLEAR_ERRSV();
3433
3434     SAVEHINTS();
3435     if (clear_hints) {
3436         PL_hints = 0;
3437         hv_clear(GvHV(PL_hintgv));
3438     }
3439     else {
3440         PL_hints = saveop->op_private & OPpEVAL_COPHH
3441                      ? oldcurcop->cop_hints : saveop->op_targ;
3442
3443         /* making 'use re eval' not be in scope when compiling the
3444          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3445          * infinite recursion when S_has_runtime_code() gives a false
3446          * positive: the second time round, HINT_RE_EVAL isn't set so we
3447          * don't bother calling S_has_runtime_code() */
3448         if (PL_in_eval & EVAL_RE_REPARSING)
3449             PL_hints &= ~HINT_RE_EVAL;
3450
3451         if (hh) {
3452             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3453             SvREFCNT_dec(GvHV(PL_hintgv));
3454             GvHV(PL_hintgv) = hh;
3455         }
3456     }
3457     SAVECOMPILEWARNINGS();
3458     if (clear_hints) {
3459         if (PL_dowarn & G_WARN_ALL_ON)
3460             PL_compiling.cop_warnings = pWARN_ALL ;
3461         else if (PL_dowarn & G_WARN_ALL_OFF)
3462             PL_compiling.cop_warnings = pWARN_NONE ;
3463         else
3464             PL_compiling.cop_warnings = pWARN_STD ;
3465     }
3466     else {
3467         PL_compiling.cop_warnings =
3468             DUP_WARNINGS(oldcurcop->cop_warnings);
3469         cophh_free(CopHINTHASH_get(&PL_compiling));
3470         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3471             /* The label, if present, is the first entry on the chain. So rather
3472                than writing a blank label in front of it (which involves an
3473                allocation), just use the next entry in the chain.  */
3474             PL_compiling.cop_hints_hash
3475                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3476             /* Check the assumption that this removed the label.  */
3477             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3478         }
3479         else
3480             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3481     }
3482
3483     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3484
3485     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3486      * so honour CATCH_GET and trap it here if necessary */
3487
3488     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3489
3490     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3491         SV **newsp;                     /* Used by POPBLOCK. */
3492         PERL_CONTEXT *cx;
3493         I32 optype;                     /* Used by POPEVAL. */
3494         SV *namesv;
3495         SV *errsv = NULL;
3496
3497         cx = NULL;
3498         namesv = NULL;
3499         PERL_UNUSED_VAR(newsp);
3500         PERL_UNUSED_VAR(optype);
3501
3502         /* note that if yystatus == 3, then the EVAL CX block has already
3503          * been popped, and various vars restored */
3504         PL_op = saveop;
3505         if (yystatus != 3) {
3506             if (PL_eval_root) {
3507                 op_free(PL_eval_root);
3508                 PL_eval_root = NULL;
3509             }
3510             SP = PL_stack_base + POPMARK;       /* pop original mark */
3511             POPBLOCK(cx,PL_curpm);
3512             POPEVAL(cx);
3513             namesv = cx->blk_eval.old_namesv;
3514             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3515             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3516         }
3517
3518         errsv = ERRSV;
3519         if (in_require) {
3520             if (!cx) {
3521                 /* If cx is still NULL, it means that we didn't go in the
3522                  * POPEVAL branch. */
3523                 cx = &cxstack[cxstack_ix];
3524                 assert(CxTYPE(cx) == CXt_EVAL);
3525                 namesv = cx->blk_eval.old_namesv;
3526             }
3527             (void)hv_store(GvHVn(PL_incgv),
3528                            SvPVX_const(namesv),
3529                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3530                            &PL_sv_undef, 0);
3531             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3532                        SVfARG(errsv
3533                                 ? errsv
3534                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3535         }
3536         else {
3537             if (!*(SvPV_nolen_const(errsv))) {
3538                 sv_setpvs(errsv, "Compilation error");
3539             }
3540         }
3541         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3542         PUTBACK;
3543         return FALSE;
3544     }
3545     else
3546         LEAVE_with_name("evalcomp");
3547
3548     CopLINE_set(&PL_compiling, 0);
3549     SAVEFREEOP(PL_eval_root);
3550     cv_forget_slab(evalcv);
3551
3552     DEBUG_x(dump_eval());
3553
3554     /* Register with debugger: */
3555     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3556         CV * const cv = get_cvs("DB::postponed", 0);
3557         if (cv) {
3558             dSP;
3559             PUSHMARK(SP);
3560             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3561             PUTBACK;
3562             call_sv(MUTABLE_SV(cv), G_DISCARD);
3563         }
3564     }
3565
3566     if (PL_unitcheckav) {
3567         OP *es = PL_eval_start;
3568         call_list(PL_scopestack_ix, PL_unitcheckav);
3569         PL_eval_start = es;
3570     }
3571
3572     /* compiled okay, so do it */
3573
3574     CvDEPTH(evalcv) = 1;
3575     SP = PL_stack_base + POPMARK;               /* pop original mark */
3576     PL_op = saveop;                     /* The caller may need it. */
3577     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3578
3579     PUTBACK;
3580     return TRUE;
3581 }
3582
3583 STATIC PerlIO *
3584 S_check_type_and_open(pTHX_ SV *name)
3585 {
3586     Stat_t st;
3587     STRLEN len;
3588     const char *p = SvPV_const(name, len);
3589     int st_rc;
3590
3591     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3592
3593     /* checking here captures a reasonable error message when
3594      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3595      * user gets a confusing message about looking for the .pmc file
3596      * rather than for the .pm file.
3597      * This check prevents a \0 in @INC causing problems.
3598      */
3599     if (!IS_SAFE_PATHNAME(p, len, "require"))
3600         return NULL;
3601
3602     /* we use the value of errno later to see how stat() or open() failed.
3603      * We don't want it set if the stat succeeded but we still failed,
3604      * such as if the name exists, but is a directory */
3605     errno = 0;
3606
3607     st_rc = PerlLIO_stat(p, &st);
3608
3609     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3610         return NULL;
3611     }
3612
3613 #if !defined(PERLIO_IS_STDIO)
3614     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3615 #else
3616     return PerlIO_open(p, PERL_SCRIPT_MODE);
3617 #endif
3618 }
3619
3620 #ifndef PERL_DISABLE_PMC
3621 STATIC PerlIO *
3622 S_doopen_pm(pTHX_ SV *name)
3623 {
3624     STRLEN namelen;
3625     const char *p = SvPV_const(name, namelen);
3626
3627     PERL_ARGS_ASSERT_DOOPEN_PM;
3628
3629     /* check the name before trying for the .pmc name to avoid the
3630      * warning referring to the .pmc which the user probably doesn't
3631      * know or care about
3632      */
3633     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3634         return NULL;
3635
3636     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3637         SV *const pmcsv = sv_newmortal();
3638         Stat_t pmcstat;
3639
3640         SvSetSV_nosteal(pmcsv,name);
3641         sv_catpvs(pmcsv, "c");
3642
3643         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3644             return check_type_and_open(pmcsv);
3645     }
3646     return check_type_and_open(name);
3647 }
3648 #else
3649 #  define doopen_pm(name) check_type_and_open(name)
3650 #endif /* !PERL_DISABLE_PMC */
3651
3652 /* require doesn't search for absolute names, or when the name is
3653    explicity relative the current directory */
3654 PERL_STATIC_INLINE bool
3655 S_path_is_searchable(const char *name)
3656 {
3657     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3658
3659     if (PERL_FILE_IS_ABSOLUTE(name)
3660 #ifdef WIN32
3661         || (*name == '.' && ((name[1] == '/' ||
3662                              (name[1] == '.' && name[2] == '/'))
3663                          || (name[1] == '\\' ||
3664                              ( name[1] == '.' && name[2] == '\\')))
3665             )
3666 #else
3667         || (*name == '.' && (name[1] == '/' ||
3668                              (name[1] == '.' && name[2] == '/')))
3669 #endif
3670          )
3671     {
3672         return FALSE;
3673     }
3674     else
3675         return TRUE;
3676 }
3677
3678 PP(pp_require)
3679 {
3680     dVAR; dSP;
3681     PERL_CONTEXT *cx;
3682     SV *sv;
3683     const char *name;
3684     STRLEN len;
3685     char * unixname;
3686     STRLEN unixlen;
3687 #ifdef VMS
3688     int vms_unixname = 0;
3689     char *unixdir;
3690 #endif
3691     const char *tryname = NULL;
3692     SV *namesv = NULL;
3693     const I32 gimme = GIMME_V;
3694     int filter_has_file = 0;
3695     PerlIO *tryrsfp = NULL;
3696     SV *filter_cache = NULL;
3697     SV *filter_state = NULL;
3698     SV *filter_sub = NULL;
3699     SV *hook_sv = NULL;
3700     SV *encoding;
3701     OP *op;
3702     int saved_errno;
3703     bool path_searchable;
3704
3705     sv = POPs;
3706     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3707         sv = sv_2mortal(new_version(sv));
3708         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3709             upg_version(PL_patchlevel, TRUE);
3710         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3711             if ( vcmp(sv,PL_patchlevel) <= 0 )
3712                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3713                     SVfARG(sv_2mortal(vnormal(sv))),
3714                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3715                 );
3716         }
3717         else {
3718             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3719                 I32 first = 0;
3720                 AV *lav;
3721                 SV * const req = SvRV(sv);
3722                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3723
3724                 /* get the left hand term */
3725                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3726
3727                 first  = SvIV(*av_fetch(lav,0,0));
3728                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3729                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3730                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3731                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3732                    ) {
3733                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3734                         "%"SVf", stopped",
3735                         SVfARG(sv_2mortal(vnormal(req))),
3736                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3737                     );
3738                 }
3739                 else { /* probably 'use 5.10' or 'use 5.8' */
3740                     SV *hintsv;
3741                     I32 second = 0;
3742
3743                     if (av_tindex(lav)>=1)
3744                         second = SvIV(*av_fetch(lav,1,0));
3745
3746                     second /= second >= 600  ? 100 : 10;
3747                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3748                                            (int)first, (int)second);
3749                     upg_version(hintsv, TRUE);
3750
3751                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3752                         "--this is only %"SVf", stopped",
3753                         SVfARG(sv_2mortal(vnormal(req))),
3754                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3755                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3756                     );
3757                 }
3758             }
3759         }
3760
3761         RETPUSHYES;
3762     }
3763     name = SvPV_const(sv, len);
3764     if (!(name && len > 0 && *name))
3765         DIE(aTHX_ "Null filename used");
3766     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3767         DIE(aTHX_ "Can't locate %s:   %s",
3768             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3769                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3770             Strerror(ENOENT));
3771     }
3772     TAINT_PROPER("require");
3773
3774     path_searchable = path_is_searchable(name);
3775
3776 #ifdef VMS
3777     /* The key in the %ENV hash is in the syntax of file passed as the argument
3778      * usually this is in UNIX format, but sometimes in VMS format, which
3779      * can result in a module being pulled in more than once.
3780      * To prevent this, the key must be stored in UNIX format if the VMS
3781      * name can be translated to UNIX.
3782      */
3783
3784     if ((unixname =
3785           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3786          != NULL) {
3787         unixlen = strlen(unixname);
3788         vms_unixname = 1;
3789     }
3790     else
3791 #endif
3792     {
3793         /* if not VMS or VMS name can not be translated to UNIX, pass it
3794          * through.
3795          */
3796         unixname = (char *) name;
3797         unixlen = len;
3798     }
3799     if (PL_op->op_type == OP_REQUIRE) {
3800         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3801                                           unixname, unixlen, 0);
3802         if ( svp ) {
3803             if (*svp != &PL_sv_undef)
3804                 RETPUSHYES;
3805             else
3806                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3807                             "Compilation failed in require", unixname);
3808         }
3809     }
3810
3811     LOADING_FILE_PROBE(unixname);
3812
3813     /* prepare to compile file */
3814
3815     if (!path_searchable) {
3816         /* At this point, name is SvPVX(sv)  */
3817         tryname = name;
3818         tryrsfp = doopen_pm(sv);
3819     }
3820     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3821         AV * const ar = GvAVn(PL_incgv);
3822         SSize_t i;
3823 #ifdef VMS
3824         if (vms_unixname)
3825 #endif
3826         {
3827             SV *nsv = sv;
3828             namesv = newSV_type(SVt_PV);
3829             for (i = 0; i <= AvFILL(ar); i++) {
3830                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3831
3832                 SvGETMAGIC(dirsv);
3833                 if (SvROK(dirsv)) {
3834                     int count;
3835                     SV **svp;
3836                     SV *loader = dirsv;
3837
3838                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3839                         && !SvOBJECT(SvRV(loader)))
3840                     {
3841                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3842                         SvGETMAGIC(loader);
3843                     }
3844
3845                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3846                                    PTR2UV(SvRV(dirsv)), name);
3847                     tryname = SvPVX_const(namesv);
3848                     tryrsfp = NULL;
3849
3850                     if (SvPADTMP(nsv)) {
3851                         nsv = sv_newmortal();
3852                         SvSetSV_nosteal(nsv,sv);
3853                     }
3854
3855                     ENTER_with_name("call_INC");
3856                     SAVETMPS;
3857                     EXTEND(SP, 2);
3858
3859                     PUSHMARK(SP);
3860                     PUSHs(dirsv);
3861                     PUSHs(nsv);
3862                     PUTBACK;
3863                     if (SvGMAGICAL(loader)) {
3864                         SV *l = sv_newmortal();
3865                         sv_setsv_nomg(l, loader);
3866                         loader = l;
3867                     }
3868                     if (sv_isobject(loader))
3869                         count = call_method("INC", G_ARRAY);
3870                     else
3871                         count = call_sv(loader, G_ARRAY);
3872                     SPAGAIN;
3873
3874                     if (count > 0) {
3875                         int i = 0;
3876                         SV *arg;
3877
3878                         SP -= count - 1;
3879                         arg = SP[i++];
3880
3881                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3882                             && !isGV_with_GP(SvRV(arg))) {
3883                             filter_cache = SvRV(arg);
3884
3885                             if (i < count) {
3886                                 arg = SP[i++];
3887                             }
3888                         }
3889
3890                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3891                             arg = SvRV(arg);
3892                         }
3893
3894                         if (isGV_with_GP(arg)) {
3895                             IO * const io = GvIO((const GV *)arg);
3896
3897                             ++filter_has_file;
3898
3899                             if (io) {
3900                                 tryrsfp = IoIFP(io);
3901                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3902                                     PerlIO_close(IoOFP(io));
3903                                 }
3904                                 IoIFP(io) = NULL;
3905                                 IoOFP(io) = NULL;
3906                             }
3907
3908                             if (i < count) {
3909                                 arg = SP[i++];
3910                             }
3911                         }
3912
3913                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3914                             filter_sub = arg;
3915                             SvREFCNT_inc_simple_void_NN(filter_sub);
3916
3917                             if (i < count) {
3918                                 filter_state = SP[i];
3919                                 SvREFCNT_inc_simple_void(filter_state);
3920                             }
3921                         }
3922
3923                         if (!tryrsfp && (filter_cache || filter_sub)) {
3924                             tryrsfp = PerlIO_open(BIT_BUCKET,
3925                                                   PERL_SCRIPT_MODE);
3926                         }
3927                         SP--;
3928                     }
3929
3930                     /* FREETMPS may free our filter_cache */
3931                     SvREFCNT_inc_simple_void(filter_cache);
3932
3933                     PUTBACK;
3934                     FREETMPS;
3935                     LEAVE_with_name("call_INC");
3936
3937                     /* Now re-mortalize it. */
3938                     sv_2mortal(filter_cache);
3939
3940                     /* Adjust file name if the hook has set an %INC entry.
3941                        This needs to happen after the FREETMPS above.  */
3942                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3943                     if (svp)
3944                         tryname = SvPV_nolen_const(*svp);
3945
3946                     if (tryrsfp) {
3947                         hook_sv = dirsv;
3948                         break;
3949                     }
3950
3951                     filter_has_file = 0;
3952                     filter_cache = NULL;
3953                     if (filter_state) {
3954                         SvREFCNT_dec_NN(filter_state);
3955                         filter_state = NULL;
3956                     }
3957                     if (filter_sub) {
3958                         SvREFCNT_dec_NN(filter_sub);
3959                         filter_sub = NULL;
3960                     }
3961                 }
3962                 else {
3963                   if (path_searchable) {
3964                     const char *dir;
3965                     STRLEN dirlen;
3966
3967                     if (SvOK(dirsv)) {
3968                         dir = SvPV_nomg_const(dirsv, dirlen);
3969                     } else {
3970                         dir = "";
3971                         dirlen = 0;
3972                     }
3973
3974                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3975                         continue;
3976 #ifdef VMS
3977                     if ((unixdir =
3978                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3979                          == NULL)
3980                         continue;
3981                     sv_setpv(namesv, unixdir);
3982                     sv_catpv(namesv, unixname);
3983 #else
3984 #  ifdef __SYMBIAN32__
3985                     if (PL_origfilename[0] &&
3986                         PL_origfilename[1] == ':' &&
3987                         !(dir[0] && dir[1] == ':'))
3988                         Perl_sv_setpvf(aTHX_ namesv,
3989                                        "%c:%s\\%s",
3990                                        PL_origfilename[0],
3991                                        dir, name);
3992                     else
3993                         Perl_sv_setpvf(aTHX_ namesv,
3994                                        "%s\\%s",
3995                                        dir, name);
3996 #  else
3997                     /* The equivalent of
3998                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3999                        but without the need to parse the format string, or
4000                        call strlen on either pointer, and with the correct
4001                        allocation up front.  */
4002                     {
4003                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4004
4005                         memcpy(tmp, dir, dirlen);
4006                         tmp +=dirlen;
4007
4008                         /* Avoid '<dir>//<file>' */
4009                         if (!dirlen || *(tmp-1) != '/') {
4010                             *tmp++ = '/';
4011                         } else {
4012                             /* So SvCUR_set reports the correct length below */
4013                             dirlen--;
4014                         }
4015
4016                         /* name came from an SV, so it will have a '\0' at the
4017                            end that we can copy as part of this memcpy().  */
4018                         memcpy(tmp, name, len + 1);
4019
4020                         SvCUR_set(namesv, dirlen + len + 1);
4021                         SvPOK_on(namesv);
4022                     }
4023 #  endif
4024 #endif
4025                     TAINT_PROPER("require");
4026                     tryname = SvPVX_const(namesv);
4027                     tryrsfp = doopen_pm(namesv);
4028                     if (tryrsfp) {
4029                         if (tryname[0] == '.' && tryname[1] == '/') {
4030                             ++tryname;
4031                             while (*++tryname == '/') {}
4032                         }
4033                         break;
4034                     }
4035                     else if (errno == EMFILE || errno == EACCES) {
4036                         /* no point in trying other paths if out of handles;
4037                          * on the other hand, if we couldn't open one of the
4038                          * files, then going on with the search could lead to
4039                          * unexpected results; see perl #113422
4040                          */
4041                         break;
4042                     }
4043                   }
4044                 }
4045             }
4046         }
4047     }
4048     saved_errno = errno; /* sv_2mortal can realloc things */
4049     sv_2mortal(namesv);
4050     if (!tryrsfp) {
4051         if (PL_op->op_type == OP_REQUIRE) {
4052             if(saved_errno == EMFILE || saved_errno == EACCES) {
4053                 /* diag_listed_as: Can't locate %s */
4054                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
4055             } else {
4056                 if (namesv) {                   /* did we lookup @INC? */
4057                     AV * const ar = GvAVn(PL_incgv);
4058                     SSize_t i;
4059                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4060                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4061                     for (i = 0; i <= AvFILL(ar); i++) {
4062                         sv_catpvs(inc, " ");
4063                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4064                     }
4065                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4066                         const char *c, *e = name + len - 3;
4067                         sv_catpv(msg, " (you may need to install the ");
4068                         for (c = name; c < e; c++) {
4069                             if (*c == '/') {
4070                                 sv_catpvs(msg, "::");
4071                             }
4072                             else {
4073                                 sv_catpvn(msg, c, 1);
4074                             }
4075                         }
4076                         sv_catpv(msg, " module)");
4077                     }
4078                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4079                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4080                     }
4081                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4082                         sv_catpv(msg, " (did you run h2ph?)");
4083                     }
4084
4085                     /* diag_listed_as: Can't locate %s */
4086                     DIE(aTHX_
4087                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4088                         name, msg, inc);
4089                 }
4090             }
4091             DIE(aTHX_ "Can't locate %s", name);
4092         }
4093
4094         CLEAR_ERRSV();
4095         RETPUSHUNDEF;
4096     }
4097     else
4098         SETERRNO(0, SS_NORMAL);
4099
4100     /* Assume success here to prevent recursive requirement. */
4101     /* name is never assigned to again, so len is still strlen(name)  */
4102     /* Check whether a hook in @INC has already filled %INC */
4103     if (!hook_sv) {
4104         (void)hv_store(GvHVn(PL_incgv),
4105                        unixname, unixlen, newSVpv(tryname,0),0);
4106     } else {
4107         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4108         if (!svp)
4109             (void)hv_store(GvHVn(PL_incgv),
4110                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4111     }
4112
4113     ENTER_with_name("eval");
4114     SAVETMPS;
4115     SAVECOPFILE_FREE(&PL_compiling);
4116     CopFILE_set(&PL_compiling, tryname);
4117     lex_start(NULL, tryrsfp, 0);
4118
4119     if (filter_sub || filter_cache) {
4120         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4121            than hanging another SV from it. In turn, filter_add() optionally
4122            takes the SV to use as the filter (or creates a new SV if passed
4123            NULL), so simply pass in whatever value filter_cache has.  */
4124         SV * const fc = filter_cache ? newSV(0) : NULL;
4125         SV *datasv;
4126         if (fc) sv_copypv(fc, filter_cache);
4127         datasv = filter_add(S_run_user_filter, fc);
4128         IoLINES(datasv) = filter_has_file;
4129         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4130         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4131     }
4132
4133     /* switch to eval mode */
4134     PUSHBLOCK(cx, CXt_EVAL, SP);
4135     PUSHEVAL(cx, name);
4136     cx->blk_eval.retop = PL_op->op_next;
4137
4138     SAVECOPLINE(&PL_compiling);
4139     CopLINE_set(&PL_compiling, 0);
4140
4141     PUTBACK;
4142
4143     /* Store and reset encoding. */
4144     encoding = PL_encoding;
4145     PL_encoding = NULL;
4146
4147     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4148         op = DOCATCH(PL_eval_start);
4149     else
4150         op = PL_op->op_next;
4151
4152     /* Restore encoding. */
4153     PL_encoding = encoding;
4154
4155     LOADED_FILE_PROBE(unixname);
4156
4157     return op;
4158 }
4159
4160 /* This is a op added to hold the hints hash for
4161    pp_entereval. The hash can be modified by the code
4162    being eval'ed, so we return a copy instead. */
4163
4164 PP(pp_hintseval)
4165 {
4166     dVAR;
4167     dSP;
4168     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4169     RETURN;
4170 }
4171
4172
4173 PP(pp_entereval)
4174 {
4175     dVAR; dSP;
4176     PERL_CONTEXT *cx;
4177     SV *sv;
4178     const I32 gimme = GIMME_V;
4179     const U32 was = PL_breakable_sub_gen;
4180     char tbuf[TYPE_DIGITS(long) + 12];
4181     bool saved_delete = FALSE;
4182     char *tmpbuf = tbuf;
4183     STRLEN len;
4184     CV* runcv;
4185     U32 seq, lex_flags = 0;
4186     HV *saved_hh = NULL;
4187     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4188
4189     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4190         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4191     }
4192     else if (PL_hints & HINT_LOCALIZE_HH || (
4193                 PL_op->op_private & OPpEVAL_COPHH
4194              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4195             )) {
4196         saved_hh = cop_hints_2hv(PL_curcop, 0);
4197         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4198     }
4199     sv = POPs;
4200     if (!SvPOK(sv)) {
4201         /* make sure we've got a plain PV (no overload etc) before testing
4202          * for taint. Making a copy here is probably overkill, but better
4203          * safe than sorry */
4204         STRLEN len;
4205         const char * const p = SvPV_const(sv, len);
4206
4207         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4208         lex_flags |= LEX_START_COPIED;
4209
4210         if (bytes && SvUTF8(sv))
4211             SvPVbyte_force(sv, len);
4212     }
4213     else if (bytes && SvUTF8(sv)) {
4214         /* Don't modify someone else's scalar */
4215         STRLEN len;
4216         sv = newSVsv(sv);
4217         (void)sv_2mortal(sv);
4218         SvPVbyte_force(sv,len);
4219         lex_flags |= LEX_START_COPIED;
4220     }
4221
4222     TAINT_IF(SvTAINTED(sv));
4223     TAINT_PROPER("eval");
4224
4225     ENTER_with_name("eval");
4226     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4227                            ? LEX_IGNORE_UTF8_HINTS
4228                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4229                         )
4230              );
4231     SAVETMPS;
4232
4233     /* switch to eval mode */
4234
4235     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4236         SV * const temp_sv = sv_newmortal();
4237         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4238                        (unsigned long)++PL_evalseq,
4239                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4240         tmpbuf = SvPVX(temp_sv);
4241         len = SvCUR(temp_sv);
4242     }
4243     else
4244         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4245     SAVECOPFILE_FREE(&PL_compiling);
4246     CopFILE_set(&PL_compiling, tmpbuf+2);
4247     SAVECOPLINE(&PL_compiling);
4248     CopLINE_set(&PL_compiling, 1);
4249     /* special case: an eval '' executed within the DB package gets lexically
4250      * placed in the first non-DB CV rather than the current CV - this
4251      * allows the debugger to execute code, find lexicals etc, in the
4252      * scope of the code being debugged. Passing &seq gets find_runcv
4253      * to do the dirty work for us */
4254     runcv = find_runcv(&seq);
4255
4256     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4257     PUSHEVAL(cx, 0);
4258     cx->blk_eval.retop = PL_op->op_next;
4259
4260     /* prepare to compile string */
4261
4262     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4263         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4264     else {
4265         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4266            deleting the eval's FILEGV from the stash before gv_check() runs
4267            (i.e. before run-time proper). To work around the coredump that
4268            ensues, we always turn GvMULTI_on for any globals that were
4269            introduced within evals. See force_ident(). GSAR 96-10-12 */
4270         char *const safestr = savepvn(tmpbuf, len);
4271         SAVEDELETE(PL_defstash, safestr, len);
4272         saved_delete = TRUE;
4273     }
4274
4275     PUTBACK;
4276
4277     if (doeval(gimme, runcv, seq, saved_hh)) {
4278         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4279             ? (PERLDB_LINE || PERLDB_SAVESRC)
4280             :  PERLDB_SAVESRC_NOSUBS) {
4281             /* Retain the filegv we created.  */
4282         } else if (!saved_delete) {
4283             char *const safestr = savepvn(tmpbuf, len);
4284             SAVEDELETE(PL_defstash, safestr, len);
4285         }
4286         return DOCATCH(PL_eval_start);
4287     } else {
4288         /* We have already left the scope set up earlier thanks to the LEAVE
4289            in doeval().  */
4290         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4291             ? (PERLDB_LINE || PERLDB_SAVESRC)
4292             :  PERLDB_SAVESRC_INVALID) {
4293             /* Retain the filegv we created.  */
4294         } else if (!saved_delete) {
4295             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4296         }
4297         return PL_op->op_next;
4298     }
4299 }
4300
4301 PP(pp_leaveeval)
4302 {
4303     dVAR; dSP;
4304     SV **newsp;
4305     PMOP *newpm;
4306     I32 gimme;
4307     PERL_CONTEXT *cx;
4308     OP *retop;
4309     const U8 save_flags = PL_op -> op_flags;
4310     I32 optype;
4311     SV *namesv;
4312     CV *evalcv;
4313
4314     PERL_ASYNC_CHECK();
4315     POPBLOCK(cx,newpm);
4316     POPEVAL(cx);
4317     namesv = cx->blk_eval.old_namesv;
4318     retop = cx->blk_eval.retop;
4319     evalcv = cx->blk_eval.cv;
4320
4321     TAINT_NOT;
4322     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4323                                 gimme, SVs_TEMP, FALSE);
4324     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4325
4326 #ifdef DEBUGGING
4327     assert(CvDEPTH(evalcv) == 1);
4328 #endif
4329     CvDEPTH(evalcv) = 0;
4330
4331     if (optype == OP_REQUIRE &&
4332         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4333     {
4334         /* Unassume the success we assumed earlier. */
4335         (void)hv_delete(GvHVn(PL_incgv),
4336                         SvPVX_const(namesv),
4337                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4338                         G_DISCARD);
4339         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4340                                SVfARG(namesv));
4341         /* die_unwind() did LEAVE, or we won't be here */
4342     }
4343     else {
4344         LEAVE_with_name("eval");
4345         if (!(save_flags & OPf_SPECIAL)) {
4346             CLEAR_ERRSV();
4347         }
4348     }
4349
4350     RETURNOP(retop);
4351 }
4352
4353 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4354    close to the related Perl_create_eval_scope.  */
4355 void
4356 Perl_delete_eval_scope(pTHX)
4357 {
4358     SV **newsp;
4359     PMOP *newpm;
4360     I32 gimme;
4361     PERL_CONTEXT *cx;
4362     I32 optype;
4363
4364     POPBLOCK(cx,newpm);
4365     POPEVAL(cx);
4366     PL_curpm = newpm;
4367     LEAVE_with_name("eval_scope");
4368     PERL_UNUSED_VAR(newsp);
4369     PERL_UNUSED_VAR(gimme);
4370     PERL_UNUSED_VAR(optype);
4371 }
4372
4373 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4374    also needed by Perl_fold_constants.  */
4375 PERL_CONTEXT *
4376 Perl_create_eval_scope(pTHX_ U32 flags)
4377 {
4378     PERL_CONTEXT *cx;
4379     const I32 gimme = GIMME_V;
4380
4381     ENTER_with_name("eval_scope");
4382     SAVETMPS;
4383
4384     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4385     PUSHEVAL(cx, 0);
4386
4387     PL_in_eval = EVAL_INEVAL;
4388     if (flags & G_KEEPERR)
4389         PL_in_eval |= EVAL_KEEPERR;
4390     else
4391         CLEAR_ERRSV();
4392     if (flags & G_FAKINGEVAL) {
4393         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4394     }
4395     return cx;
4396 }
4397
4398 PP(pp_entertry)
4399 {
4400     dVAR;
4401     PERL_CONTEXT * const cx = create_eval_scope(0);
4402     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4403     return DOCATCH(PL_op->op_next);
4404 }
4405
4406 PP(pp_leavetry)
4407 {
4408     dVAR; dSP;
4409     SV **newsp;
4410     PMOP *newpm;
4411     I32 gimme;
4412     PERL_CONTEXT *cx;
4413     I32 optype;
4414
4415     PERL_ASYNC_CHECK();
4416     POPBLOCK(cx,newpm);
4417     POPEVAL(cx);
4418     PERL_UNUSED_VAR(optype);
4419
4420     TAINT_NOT;
4421     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4422                                SVs_PADTMP|SVs_TEMP, FALSE);
4423     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4424
4425     LEAVE_with_name("eval_scope");
4426     CLEAR_ERRSV();
4427     RETURN;
4428 }
4429
4430 PP(pp_entergiven)
4431 {
4432     dVAR; dSP;
4433     PERL_CONTEXT *cx;
4434     const I32 gimme = GIMME_V;
4435
4436     ENTER_with_name("given");
4437     SAVETMPS;
4438
4439     if (PL_op->op_targ) {
4440         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4441         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4442         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4443     }
4444     else {
4445         SAVE_DEFSV;
4446         DEFSV_set(POPs);
4447     }
4448
4449     PUSHBLOCK(cx, CXt_GIVEN, SP);
4450     PUSHGIVEN(cx);
4451
4452     RETURN;
4453 }
4454
4455 PP(pp_leavegiven)
4456 {
4457     dVAR; dSP;
4458     PERL_CONTEXT *cx;
4459     I32 gimme;
4460     SV **newsp;
4461     PMOP *newpm;
4462     PERL_UNUSED_CONTEXT;
4463
4464     POPBLOCK(cx,newpm);
4465     assert(CxTYPE(cx) == CXt_GIVEN);
4466
4467     TAINT_NOT;
4468     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4469                                SVs_PADTMP|SVs_TEMP, FALSE);
4470     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4471
4472     LEAVE_with_name("given");
4473     RETURN;