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     }
1361     NOT_REACHED; /* NOTREACHED */
1362 }
1363
1364 I32
1365 Perl_is_lvalue_sub(pTHX)
1366 {
1367     dVAR;
1368     const I32 cxix = dopoptosub(cxstack_ix);
1369     assert(cxix >= 0);  /* We should only be called from inside subs */
1370
1371     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1372         return CxLVAL(cxstack + cxix);
1373     else
1374         return 0;
1375 }
1376
1377 /* only used by PUSHSUB */
1378 I32
1379 Perl_was_lvalue_sub(pTHX)
1380 {
1381     dVAR;
1382     const I32 cxix = dopoptosub(cxstack_ix-1);
1383     assert(cxix >= 0);  /* We should only be called from inside subs */
1384
1385     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1386         return CxLVAL(cxstack + cxix);
1387     else
1388         return 0;
1389 }
1390
1391 STATIC I32
1392 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1393 {
1394     dVAR;
1395     I32 i;
1396
1397     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1398 #ifndef DEBUGGING
1399     PERL_UNUSED_CONTEXT;
1400 #endif
1401
1402     for (i = startingblock; i >= 0; i--) {
1403         const PERL_CONTEXT * const cx = &cxstk[i];
1404         switch (CxTYPE(cx)) {
1405         default:
1406             continue;
1407         case CXt_SUB:
1408             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1409              * twice; the first for the normal foo() call, and the second
1410              * for a faked up re-entry into the sub to execute the
1411              * code block. Hide this faked entry from the world. */
1412             if (cx->cx_type & CXp_SUB_RE_FAKE)
1413                 continue;
1414             /* FALLTHROUGH */
1415         case CXt_EVAL:
1416         case CXt_FORMAT:
1417             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1418             return i;
1419         }
1420     }
1421     return i;
1422 }
1423
1424 STATIC I32
1425 S_dopoptoeval(pTHX_ I32 startingblock)
1426 {
1427     dVAR;
1428     I32 i;
1429     for (i = startingblock; i >= 0; i--) {
1430         const PERL_CONTEXT *cx = &cxstack[i];
1431         switch (CxTYPE(cx)) {
1432         default:
1433             continue;
1434         case CXt_EVAL:
1435             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1436             return i;
1437         }
1438     }
1439     return i;
1440 }
1441
1442 STATIC I32
1443 S_dopoptoloop(pTHX_ I32 startingblock)
1444 {
1445     dVAR;
1446     I32 i;
1447     for (i = startingblock; i >= 0; i--) {
1448         const PERL_CONTEXT * const cx = &cxstack[i];
1449         switch (CxTYPE(cx)) {
1450         case CXt_SUBST:
1451         case CXt_SUB:
1452         case CXt_FORMAT:
1453         case CXt_EVAL:
1454         case CXt_NULL:
1455             /* diag_listed_as: Exiting subroutine via %s */
1456             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1457                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1458             if ((CxTYPE(cx)) == CXt_NULL)
1459                 return -1;
1460             break;
1461         case CXt_LOOP_LAZYIV:
1462         case CXt_LOOP_LAZYSV:
1463         case CXt_LOOP_FOR:
1464         case CXt_LOOP_PLAIN:
1465             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1466             return i;
1467         }
1468     }
1469     return i;
1470 }
1471
1472 STATIC I32
1473 S_dopoptogiven(pTHX_ I32 startingblock)
1474 {
1475     dVAR;
1476     I32 i;
1477     for (i = startingblock; i >= 0; i--) {
1478         const PERL_CONTEXT *cx = &cxstack[i];
1479         switch (CxTYPE(cx)) {
1480         default:
1481             continue;
1482         case CXt_GIVEN:
1483             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1484             return i;
1485         case CXt_LOOP_PLAIN:
1486             assert(!CxFOREACHDEF(cx));
1487             break;
1488         case CXt_LOOP_LAZYIV:
1489         case CXt_LOOP_LAZYSV:
1490         case CXt_LOOP_FOR:
1491             if (CxFOREACHDEF(cx)) {
1492                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1493                 return i;
1494             }
1495         }
1496     }
1497     return i;
1498 }
1499
1500 STATIC I32
1501 S_dopoptowhen(pTHX_ I32 startingblock)
1502 {
1503     dVAR;
1504     I32 i;
1505     for (i = startingblock; i >= 0; i--) {
1506         const PERL_CONTEXT *cx = &cxstack[i];
1507         switch (CxTYPE(cx)) {
1508         default:
1509             continue;
1510         case CXt_WHEN:
1511             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1512             return i;
1513         }
1514     }
1515     return i;
1516 }
1517
1518 void
1519 Perl_dounwind(pTHX_ I32 cxix)
1520 {
1521     dVAR;
1522     I32 optype;
1523
1524     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1525         return;
1526
1527     while (cxstack_ix > cxix) {
1528         SV *sv;
1529         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1530         DEBUG_CX("UNWIND");                                             \
1531         /* Note: we don't need to restore the base context info till the end. */
1532         switch (CxTYPE(cx)) {
1533         case CXt_SUBST:
1534             POPSUBST(cx);
1535             continue;  /* not break */
1536         case CXt_SUB:
1537             POPSUB(cx,sv);
1538             LEAVESUB(sv);
1539             break;
1540         case CXt_EVAL:
1541             POPEVAL(cx);
1542             break;
1543         case CXt_LOOP_LAZYIV:
1544         case CXt_LOOP_LAZYSV:
1545         case CXt_LOOP_FOR:
1546         case CXt_LOOP_PLAIN:
1547             POPLOOP(cx);
1548             break;
1549         case CXt_NULL:
1550             break;
1551         case CXt_FORMAT:
1552             POPFORMAT(cx);
1553             break;
1554         }
1555         cxstack_ix--;
1556     }
1557     PERL_UNUSED_VAR(optype);
1558 }
1559
1560 void
1561 Perl_qerror(pTHX_ SV *err)
1562 {
1563     dVAR;
1564
1565     PERL_ARGS_ASSERT_QERROR;
1566
1567     if (PL_in_eval) {
1568         if (PL_in_eval & EVAL_KEEPERR) {
1569                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1570                                                     SVfARG(err));
1571         }
1572         else
1573             sv_catsv(ERRSV, err);
1574     }
1575     else if (PL_errors)
1576         sv_catsv(PL_errors, err);
1577     else
1578         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1579     if (PL_parser)
1580         ++PL_parser->error_count;
1581 }
1582
1583 void
1584 Perl_die_unwind(pTHX_ SV *msv)
1585 {
1586     dVAR;
1587     SV *exceptsv = sv_mortalcopy(msv);
1588     U8 in_eval = PL_in_eval;
1589     PERL_ARGS_ASSERT_DIE_UNWIND;
1590
1591     if (in_eval) {
1592         I32 cxix;
1593         I32 gimme;
1594
1595         /*
1596          * Historically, perl used to set ERRSV ($@) early in the die
1597          * process and rely on it not getting clobbered during unwinding.
1598          * That sucked, because it was liable to get clobbered, so the
1599          * setting of ERRSV used to emit the exception from eval{} has
1600          * been moved to much later, after unwinding (see just before
1601          * JMPENV_JUMP below).  However, some modules were relying on the
1602          * early setting, by examining $@ during unwinding to use it as
1603          * a flag indicating whether the current unwinding was caused by
1604          * an exception.  It was never a reliable flag for that purpose,
1605          * being totally open to false positives even without actual
1606          * clobberage, but was useful enough for production code to
1607          * semantically rely on it.
1608          *
1609          * We'd like to have a proper introspective interface that
1610          * explicitly describes the reason for whatever unwinding
1611          * operations are currently in progress, so that those modules
1612          * work reliably and $@ isn't further overloaded.  But we don't
1613          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1614          * now *additionally* set here, before unwinding, to serve as the
1615          * (unreliable) flag that it used to.
1616          *
1617          * This behaviour is temporary, and should be removed when a
1618          * proper way to detect exceptional unwinding has been developed.
1619          * As of 2010-12, the authors of modules relying on the hack
1620          * are aware of the issue, because the modules failed on
1621          * perls 5.13.{1..7} which had late setting of $@ without this
1622          * early-setting hack.
1623          */
1624         if (!(in_eval & EVAL_KEEPERR)) {
1625             SvTEMP_off(exceptsv);
1626             sv_setsv(ERRSV, exceptsv);
1627         }
1628
1629         if (in_eval & EVAL_KEEPERR) {
1630             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1631                            SVfARG(exceptsv));
1632         }
1633
1634         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1635                && PL_curstackinfo->si_prev)
1636         {
1637             dounwind(-1);
1638             POPSTACK;
1639         }
1640
1641         if (cxix >= 0) {
1642             I32 optype;
1643             SV *namesv;
1644             PERL_CONTEXT *cx;
1645             SV **newsp;
1646             COP *oldcop;
1647             JMPENV *restartjmpenv;
1648             OP *restartop;
1649
1650             if (cxix < cxstack_ix)
1651                 dounwind(cxix);
1652
1653             POPBLOCK(cx,PL_curpm);
1654             if (CxTYPE(cx) != CXt_EVAL) {
1655                 STRLEN msglen;
1656                 const char* message = SvPVx_const(exceptsv, msglen);
1657                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1658                 PerlIO_write(Perl_error_log, message, msglen);
1659                 my_exit(1);
1660             }
1661             POPEVAL(cx);
1662             namesv = cx->blk_eval.old_namesv;
1663             oldcop = cx->blk_oldcop;
1664             restartjmpenv = cx->blk_eval.cur_top_env;
1665             restartop = cx->blk_eval.retop;
1666
1667             if (gimme == G_SCALAR)
1668                 *++newsp = &PL_sv_undef;
1669             PL_stack_sp = newsp;
1670
1671             LEAVE;
1672
1673             /* LEAVE could clobber PL_curcop (see save_re_context())
1674              * XXX it might be better to find a way to avoid messing with
1675              * PL_curcop in save_re_context() instead, but this is a more
1676              * minimal fix --GSAR */
1677             PL_curcop = oldcop;
1678
1679             if (optype == OP_REQUIRE) {
1680                 (void)hv_store(GvHVn(PL_incgv),
1681                                SvPVX_const(namesv),
1682                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1683                                &PL_sv_undef, 0);
1684                 /* note that unlike pp_entereval, pp_require isn't
1685                  * supposed to trap errors. So now that we've popped the
1686                  * EVAL that pp_require pushed, and processed the error
1687                  * message, rethrow the error */
1688                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1689                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1690                                                                     SVs_TEMP)));
1691             }
1692             if (!(in_eval & EVAL_KEEPERR))
1693                 sv_setsv(ERRSV, exceptsv);
1694             PL_restartjmpenv = restartjmpenv;
1695             PL_restartop = restartop;
1696             JMPENV_JUMP(3);
1697             assert(0); /* NOTREACHED */
1698         }
1699     }
1700
1701     write_to_stderr(exceptsv);
1702     my_failure_exit();
1703     assert(0); /* NOTREACHED */
1704 }
1705
1706 PP(pp_xor)
1707 {
1708     dVAR; dSP; dPOPTOPssrl;
1709     if (SvTRUE(left) != SvTRUE(right))
1710         RETSETYES;
1711     else
1712         RETSETNO;
1713 }
1714
1715 /*
1716
1717 =head1 CV Manipulation Functions
1718
1719 =for apidoc caller_cx
1720
1721 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1722 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1723 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1724 stack frame, so C<caller_cx(0, NULL)> will return information for the
1725 immediately-surrounding Perl code.
1726
1727 This function skips over the automatic calls to C<&DB::sub> made on the
1728 behalf of the debugger.  If the stack frame requested was a sub called by
1729 C<DB::sub>, the return value will be the frame for the call to
1730 C<DB::sub>, since that has the correct line number/etc. for the call
1731 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1732 frame for the sub call itself.
1733
1734 =cut
1735 */
1736
1737 const PERL_CONTEXT *
1738 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1739 {
1740     I32 cxix = dopoptosub(cxstack_ix);
1741     const PERL_CONTEXT *cx;
1742     const PERL_CONTEXT *ccstack = cxstack;
1743     const PERL_SI *top_si = PL_curstackinfo;
1744
1745     for (;;) {
1746         /* we may be in a higher stacklevel, so dig down deeper */
1747         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1748             top_si = top_si->si_prev;
1749             ccstack = top_si->si_cxstack;
1750             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1751         }
1752         if (cxix < 0)
1753             return NULL;
1754         /* caller() should not report the automatic calls to &DB::sub */
1755         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1756                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1757             count++;
1758         if (!count--)
1759             break;
1760         cxix = dopoptosub_at(ccstack, cxix - 1);
1761     }
1762
1763     cx = &ccstack[cxix];
1764     if (dbcxp) *dbcxp = cx;
1765
1766     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1767         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1768         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1769            field below is defined for any cx. */
1770         /* caller() should not report the automatic calls to &DB::sub */
1771         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1772             cx = &ccstack[dbcxix];
1773     }
1774
1775     return cx;
1776 }
1777
1778 PP(pp_caller)
1779 {
1780     dVAR;
1781     dSP;
1782     const PERL_CONTEXT *cx;
1783     const PERL_CONTEXT *dbcx;
1784     I32 gimme;
1785     const HEK *stash_hek;
1786     I32 count = 0;
1787     bool has_arg = MAXARG && TOPs;
1788     const COP *lcop;
1789
1790     if (MAXARG) {
1791       if (has_arg)
1792         count = POPi;
1793       else (void)POPs;
1794     }
1795
1796     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1797     if (!cx) {
1798         if (GIMME != G_ARRAY) {
1799             EXTEND(SP, 1);
1800             RETPUSHUNDEF;
1801         }
1802         RETURN;
1803     }
1804
1805     DEBUG_CX("CALLER");
1806     assert(CopSTASH(cx->blk_oldcop));
1807     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1808       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1809       : NULL;
1810     if (GIMME != G_ARRAY) {
1811         EXTEND(SP, 1);
1812         if (!stash_hek)
1813             PUSHs(&PL_sv_undef);
1814         else {
1815             dTARGET;
1816             sv_sethek(TARG, stash_hek);
1817             PUSHs(TARG);
1818         }
1819         RETURN;
1820     }
1821
1822     EXTEND(SP, 11);
1823
1824     if (!stash_hek)
1825         PUSHs(&PL_sv_undef);
1826     else {
1827         dTARGET;
1828         sv_sethek(TARG, stash_hek);
1829         PUSHTARG;
1830     }
1831     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1832     lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling,
1833                        cx->blk_sub.retop, TRUE);
1834     if (!lcop)
1835         lcop = cx->blk_oldcop;
1836     mPUSHi((I32)CopLINE(lcop));
1837     if (!has_arg)
1838         RETURN;
1839     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1840         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1841         /* So is ccstack[dbcxix]. */
1842         if (cvgv && isGV(cvgv)) {
1843             SV * const sv = newSV(0);
1844             gv_efullname3(sv, cvgv, NULL);
1845             mPUSHs(sv);
1846             PUSHs(boolSV(CxHASARGS(cx)));
1847         }
1848         else {
1849             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1850             PUSHs(boolSV(CxHASARGS(cx)));
1851         }
1852     }
1853     else {
1854         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1855         mPUSHi(0);
1856     }
1857     gimme = (I32)cx->blk_gimme;
1858     if (gimme == G_VOID)
1859         PUSHs(&PL_sv_undef);
1860     else
1861         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1862     if (CxTYPE(cx) == CXt_EVAL) {
1863         /* eval STRING */
1864         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1865             SV *cur_text = cx->blk_eval.cur_text;
1866             if (SvCUR(cur_text) >= 2) {
1867                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1868                                      SvUTF8(cur_text)|SVs_TEMP));
1869             }
1870             else {
1871                 /* I think this is will always be "", but be sure */
1872                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1873             }
1874
1875             PUSHs(&PL_sv_no);
1876         }
1877         /* require */
1878         else if (cx->blk_eval.old_namesv) {
1879             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1880             PUSHs(&PL_sv_yes);
1881         }
1882         /* eval BLOCK (try blocks have old_namesv == 0) */
1883         else {
1884             PUSHs(&PL_sv_undef);
1885             PUSHs(&PL_sv_undef);
1886         }
1887     }
1888     else {
1889         PUSHs(&PL_sv_undef);
1890         PUSHs(&PL_sv_undef);
1891     }
1892     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1893         && CopSTASH_eq(PL_curcop, PL_debstash))
1894     {
1895         AV * const ary = cx->blk_sub.argarray;
1896         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1897
1898         Perl_init_dbargs(aTHX);
1899
1900         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1901             av_extend(PL_dbargs, AvFILLp(ary) + off);
1902         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1903         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1904     }
1905     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1906     {
1907         SV * mask ;
1908         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1909
1910         if  (old_warnings == pWARN_NONE)
1911             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1912         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1913             mask = &PL_sv_undef ;
1914         else if (old_warnings == pWARN_ALL ||
1915                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1916             /* Get the bit mask for $warnings::Bits{all}, because
1917              * it could have been extended by warnings::register */
1918             SV **bits_all;
1919             HV * const bits = get_hv("warnings::Bits", 0);
1920             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1921                 mask = newSVsv(*bits_all);
1922             }
1923             else {
1924                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1925             }
1926         }
1927         else
1928             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1929         mPUSHs(mask);
1930     }
1931
1932     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1933           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1934           : &PL_sv_undef);
1935     RETURN;
1936 }
1937
1938 PP(pp_reset)
1939 {
1940     dVAR;
1941     dSP;
1942     const char * tmps;
1943     STRLEN len = 0;
1944     if (MAXARG < 1 || (!TOPs && !POPs))
1945         tmps = NULL, len = 0;
1946     else
1947         tmps = SvPVx_const(POPs, len);
1948     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1949     PUSHs(&PL_sv_yes);
1950     RETURN;
1951 }
1952
1953 /* like pp_nextstate, but used instead when the debugger is active */
1954
1955 PP(pp_dbstate)
1956 {
1957     dVAR;
1958     PL_curcop = (COP*)PL_op;
1959     TAINT_NOT;          /* Each statement is presumed innocent */
1960     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1961     FREETMPS;
1962
1963     PERL_ASYNC_CHECK();
1964
1965     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1966             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1967     {
1968         dSP;
1969         PERL_CONTEXT *cx;
1970         const I32 gimme = G_ARRAY;
1971         U8 hasargs;
1972         GV * const gv = PL_DBgv;
1973         CV * cv = NULL;
1974
1975         if (gv && isGV_with_GP(gv))
1976             cv = GvCV(gv);
1977
1978         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1979             DIE(aTHX_ "No DB::DB routine defined");
1980
1981         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1982             /* don't do recursive DB::DB call */
1983             return NORMAL;
1984
1985         ENTER;
1986         SAVETMPS;
1987
1988         SAVEI32(PL_debug);
1989         SAVESTACK_POS();
1990         PL_debug = 0;
1991         hasargs = 0;
1992         SPAGAIN;
1993
1994         if (CvISXSUB(cv)) {
1995             PUSHMARK(SP);
1996             (void)(*CvXSUB(cv))(aTHX_ cv);
1997             FREETMPS;
1998             LEAVE;
1999             return NORMAL;
2000         }
2001         else {
2002             PUSHBLOCK(cx, CXt_SUB, SP);
2003             PUSHSUB_DB(cx);
2004             cx->blk_sub.retop = PL_op->op_next;
2005             CvDEPTH(cv)++;
2006             if (CvDEPTH(cv) >= 2) {
2007                 PERL_STACK_OVERFLOW_CHECK();
2008                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2009             }
2010             SAVECOMPPAD();
2011             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2012             RETURNOP(CvSTART(cv));
2013         }
2014     }
2015     else
2016         return NORMAL;
2017 }
2018
2019 /* SVs on the stack that have any of the flags passed in are left as is.
2020    Other SVs are protected via the mortals stack if lvalue is true, and
2021    copied otherwise. */
2022
2023 STATIC SV **
2024 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2025                               U32 flags, bool lvalue)
2026 {
2027     bool padtmp = 0;
2028     PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2029
2030     if (flags & SVs_PADTMP) {
2031         flags &= ~SVs_PADTMP;
2032         padtmp = 1;
2033     }
2034     if (gimme == G_SCALAR) {
2035         if (MARK < SP)
2036             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2037                             ? *SP
2038                             : lvalue
2039                                 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2040                                 : sv_mortalcopy(*SP);
2041         else {
2042             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2043             MARK = newsp;
2044             MEXTEND(MARK, 1);
2045             *++MARK = &PL_sv_undef;
2046             return MARK;
2047         }
2048     }
2049     else if (gimme == G_ARRAY) {
2050         /* in case LEAVE wipes old return values */
2051         while (++MARK <= SP) {
2052             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2053                 *++newsp = *MARK;
2054             else {
2055                 *++newsp = lvalue
2056                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2057                             : sv_mortalcopy(*MARK);
2058                 TAINT_NOT;      /* Each item is independent */
2059             }
2060         }
2061         /* When this function was called with MARK == newsp, we reach this
2062          * point with SP == newsp. */
2063     }
2064
2065     return newsp;
2066 }
2067
2068 PP(pp_enter)
2069 {
2070     dVAR; dSP;
2071     PERL_CONTEXT *cx;
2072     I32 gimme = GIMME_V;
2073
2074     ENTER_with_name("block");
2075
2076     SAVETMPS;
2077     PUSHBLOCK(cx, CXt_BLOCK, SP);
2078
2079     RETURN;
2080 }
2081
2082 PP(pp_leave)
2083 {
2084     dVAR; dSP;
2085     PERL_CONTEXT *cx;
2086     SV **newsp;
2087     PMOP *newpm;
2088     I32 gimme;
2089
2090     if (PL_op->op_flags & OPf_SPECIAL) {
2091         cx = &cxstack[cxstack_ix];
2092         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2093     }
2094
2095     POPBLOCK(cx,newpm);
2096
2097     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2098
2099     TAINT_NOT;
2100     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2101                                PL_op->op_private & OPpLVALUE);
2102     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2103
2104     LEAVE_with_name("block");
2105
2106     RETURN;
2107 }
2108
2109 PP(pp_enteriter)
2110 {
2111     dVAR; dSP; dMARK;
2112     PERL_CONTEXT *cx;
2113     const I32 gimme = GIMME_V;
2114     void *itervar; /* location of the iteration variable */
2115     U8 cxtype = CXt_LOOP_FOR;
2116
2117     ENTER_with_name("loop1");
2118     SAVETMPS;
2119
2120     if (PL_op->op_targ) {                        /* "my" variable */
2121         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2122             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2123             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2124                     SVs_PADSTALE, SVs_PADSTALE);
2125         }
2126         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2127 #ifdef USE_ITHREADS
2128         itervar = PL_comppad;
2129 #else
2130         itervar = &PAD_SVl(PL_op->op_targ);
2131 #endif
2132     }
2133     else {                                      /* symbol table variable */
2134         GV * const gv = MUTABLE_GV(POPs);
2135         SV** svp = &GvSV(gv);
2136         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2137         *svp = newSV(0);
2138         itervar = (void *)gv;
2139     }
2140
2141     if (PL_op->op_private & OPpITER_DEF)
2142         cxtype |= CXp_FOR_DEF;
2143
2144     ENTER_with_name("loop2");
2145
2146     PUSHBLOCK(cx, cxtype, SP);
2147     PUSHLOOP_FOR(cx, itervar, MARK);
2148     if (PL_op->op_flags & OPf_STACKED) {
2149         SV *maybe_ary = POPs;
2150         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2151             dPOPss;
2152             SV * const right = maybe_ary;
2153             SvGETMAGIC(sv);
2154             SvGETMAGIC(right);
2155             if (RANGE_IS_NUMERIC(sv,right)) {
2156                 cx->cx_type &= ~CXTYPEMASK;
2157                 cx->cx_type |= CXt_LOOP_LAZYIV;
2158                 /* Make sure that no-one re-orders cop.h and breaks our
2159                    assumptions */
2160                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2161 #ifdef NV_PRESERVES_UV
2162                 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2163                                   (SvNV_nomg(sv) > (NV)IV_MAX)))
2164                         ||
2165                     (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2166                                      (SvNV_nomg(right) < (NV)IV_MIN))))
2167 #else
2168                 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2169                                   ||
2170                                   ((SvNV_nomg(sv) > 0) &&
2171                                         ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2172                                          (SvNV_nomg(sv) > (NV)UV_MAX)))))
2173                         ||
2174                     (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2175                                      ||
2176                                      ((SvNV_nomg(right) > 0) &&
2177                                         ((SvUV_nomg(right) > (UV)IV_MAX) ||
2178                                          (SvNV_nomg(right) > (NV)UV_MAX))
2179                                      ))))
2180 #endif
2181                     DIE(aTHX_ "Range iterator outside integer range");
2182                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2183                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2184 #ifdef DEBUGGING
2185                 /* for correct -Dstv display */
2186                 cx->blk_oldsp = sp - PL_stack_base;
2187 #endif
2188             }
2189             else {
2190                 cx->cx_type &= ~CXTYPEMASK;
2191                 cx->cx_type |= CXt_LOOP_LAZYSV;
2192                 /* Make sure that no-one re-orders cop.h and breaks our
2193                    assumptions */
2194                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2195                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2196                 cx->blk_loop.state_u.lazysv.end = right;
2197                 SvREFCNT_inc(right);
2198                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2199                 /* This will do the upgrade to SVt_PV, and warn if the value
2200                    is uninitialised.  */
2201                 (void) SvPV_nolen_const(right);
2202                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2203                    to replace !SvOK() with a pointer to "".  */
2204                 if (!SvOK(right)) {
2205                     SvREFCNT_dec(right);
2206                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2207                 }
2208             }
2209         }
2210         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2211             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2212             SvREFCNT_inc(maybe_ary);
2213             cx->blk_loop.state_u.ary.ix =
2214                 (PL_op->op_private & OPpITER_REVERSED) ?
2215                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2216                 -1;
2217         }
2218     }
2219     else { /* iterating over items on the stack */
2220         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2221         if (PL_op->op_private & OPpITER_REVERSED) {
2222             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2223         }
2224         else {
2225             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2226         }
2227     }
2228
2229     RETURN;
2230 }
2231
2232 PP(pp_enterloop)
2233 {
2234     dVAR; dSP;
2235     PERL_CONTEXT *cx;
2236     const I32 gimme = GIMME_V;
2237
2238     ENTER_with_name("loop1");
2239     SAVETMPS;
2240     ENTER_with_name("loop2");
2241
2242     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2243     PUSHLOOP_PLAIN(cx, SP);
2244
2245     RETURN;
2246 }
2247
2248 PP(pp_leaveloop)
2249 {
2250     dVAR; dSP;
2251     PERL_CONTEXT *cx;
2252     I32 gimme;
2253     SV **newsp;
2254     PMOP *newpm;
2255     SV **mark;
2256
2257     POPBLOCK(cx,newpm);
2258     assert(CxTYPE_is_LOOP(cx));
2259     mark = newsp;
2260     newsp = PL_stack_base + cx->blk_loop.resetsp;
2261
2262     TAINT_NOT;
2263     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0,
2264                                PL_op->op_private & OPpLVALUE);
2265     PUTBACK;
2266
2267     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2268     PL_curpm = newpm;   /* ... and pop $1 et al */
2269
2270     LEAVE_with_name("loop2");
2271     LEAVE_with_name("loop1");
2272
2273     return NORMAL;
2274 }
2275
2276 STATIC void
2277 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2278                        PERL_CONTEXT *cx, PMOP *newpm)
2279 {
2280     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2281     if (gimme == G_SCALAR) {
2282         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2283             SV *sv;
2284             const char *what = NULL;
2285             if (MARK < SP) {
2286                 assert(MARK+1 == SP);
2287                 if ((SvPADTMP(TOPs) ||
2288                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2289                        == SVf_READONLY
2290                     ) &&
2291                     !SvSMAGICAL(TOPs)) {
2292                     what =
2293                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2294                         : "a readonly value" : "a temporary";
2295                 }
2296                 else goto copy_sv;
2297             }
2298             else {
2299                 /* sub:lvalue{} will take us here. */
2300                 what = "undef";
2301             }
2302             LEAVE;
2303             cxstack_ix--;
2304             POPSUB(cx,sv);
2305             PL_curpm = newpm;
2306             LEAVESUB(sv);
2307             Perl_croak(aTHX_
2308                       "Can't return %s from lvalue subroutine", what
2309             );
2310         }
2311         if (MARK < SP) {
2312               copy_sv:
2313                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2314                     if (!SvPADTMP(*SP)) {
2315                         *++newsp = SvREFCNT_inc(*SP);
2316                         FREETMPS;
2317                         sv_2mortal(*newsp);
2318                     }
2319                     else {
2320                         /* FREETMPS could clobber it */
2321                         SV *sv = SvREFCNT_inc(*SP);
2322                         FREETMPS;
2323                         *++newsp = sv_mortalcopy(sv);
2324                         SvREFCNT_dec(sv);
2325                     }
2326                 }
2327                 else
2328                     *++newsp =
2329                       SvPADTMP(*SP)
2330                        ? sv_mortalcopy(*SP)
2331                        : !SvTEMP(*SP)
2332                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2333                           : *SP;
2334         }
2335         else {
2336             EXTEND(newsp,1);
2337             *++newsp = &PL_sv_undef;
2338         }
2339         if (CxLVAL(cx) & OPpDEREF) {
2340             SvGETMAGIC(TOPs);
2341             if (!SvOK(TOPs)) {
2342                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2343             }
2344         }
2345     }
2346     else if (gimme == G_ARRAY) {
2347         assert (!(CxLVAL(cx) & OPpDEREF));
2348         if (ref || !CxLVAL(cx))
2349             while (++MARK <= SP)
2350                 *++newsp =
2351                        SvFLAGS(*MARK) & SVs_PADTMP
2352                            ? sv_mortalcopy(*MARK)
2353                      : SvTEMP(*MARK)
2354                            ? *MARK
2355                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2356         else while (++MARK <= SP) {
2357             if (*MARK != &PL_sv_undef
2358                     && (SvPADTMP(*MARK)
2359                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2360                              == SVf_READONLY
2361                        )
2362             ) {
2363                     SV *sv;
2364                     /* Might be flattened array after $#array =  */
2365                     PUTBACK;
2366                     LEAVE;
2367                     cxstack_ix--;
2368                     POPSUB(cx,sv);
2369                     PL_curpm = newpm;
2370                     LEAVESUB(sv);
2371                /* diag_listed_as: Can't return %s from lvalue subroutine */
2372                     Perl_croak(aTHX_
2373                         "Can't return a %s from lvalue subroutine",
2374                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2375             }
2376             else
2377                 *++newsp =
2378                     SvTEMP(*MARK)
2379                        ? *MARK
2380                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2381         }
2382     }
2383     PL_stack_sp = newsp;
2384 }
2385
2386 PP(pp_return)
2387 {
2388     dVAR; dSP; dMARK;
2389     PERL_CONTEXT *cx;
2390     bool popsub2 = FALSE;
2391     bool clear_errsv = FALSE;
2392     bool lval = FALSE;
2393     I32 gimme;
2394     SV **newsp;
2395     PMOP *newpm;
2396     I32 optype = 0;
2397     SV *namesv;
2398     SV *sv;
2399     OP *retop = NULL;
2400
2401     const I32 cxix = dopoptosub(cxstack_ix);
2402
2403     if (cxix < 0) {
2404         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2405                                      * sort block, which is a CXt_NULL
2406                                      * not a CXt_SUB */
2407             dounwind(0);
2408             PL_stack_base[1] = *PL_stack_sp;
2409             PL_stack_sp = PL_stack_base + 1;
2410             return 0;
2411         }
2412         else
2413             DIE(aTHX_ "Can't return outside a subroutine");
2414     }
2415     if (cxix < cxstack_ix)
2416         dounwind(cxix);
2417
2418     if (CxMULTICALL(&cxstack[cxix])) {
2419         gimme = cxstack[cxix].blk_gimme;
2420         if (gimme == G_VOID)
2421             PL_stack_sp = PL_stack_base;
2422         else if (gimme == G_SCALAR) {
2423             PL_stack_base[1] = *PL_stack_sp;
2424             PL_stack_sp = PL_stack_base + 1;
2425         }
2426         return 0;
2427     }
2428
2429     POPBLOCK(cx,newpm);
2430     switch (CxTYPE(cx)) {
2431     case CXt_SUB:
2432         popsub2 = TRUE;
2433         lval = !!CvLVALUE(cx->blk_sub.cv);
2434         retop = cx->blk_sub.retop;
2435         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2436         break;
2437     case CXt_EVAL:
2438         if (!(PL_in_eval & EVAL_KEEPERR))
2439             clear_errsv = TRUE;
2440         POPEVAL(cx);
2441         namesv = cx->blk_eval.old_namesv;
2442         retop = cx->blk_eval.retop;
2443         if (CxTRYBLOCK(cx))
2444             break;
2445         if (optype == OP_REQUIRE &&
2446             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2447         {
2448             /* Unassume the success we assumed earlier. */
2449             (void)hv_delete(GvHVn(PL_incgv),
2450                             SvPVX_const(namesv),
2451                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2452                             G_DISCARD);
2453             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2454         }
2455         break;
2456     case CXt_FORMAT:
2457         retop = cx->blk_sub.retop;
2458         POPFORMAT(cx);
2459         break;
2460     default:
2461         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2462     }
2463
2464     TAINT_NOT;
2465     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2466     else {
2467       if (gimme == G_SCALAR) {
2468         if (MARK < SP) {
2469             if (popsub2) {
2470                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2471                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2472                          && !SvMAGICAL(TOPs)) {
2473                         *++newsp = SvREFCNT_inc(*SP);
2474                         FREETMPS;
2475                         sv_2mortal(*newsp);
2476                     }
2477                     else {
2478                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2479                         FREETMPS;
2480                         *++newsp = sv_mortalcopy(sv);
2481                         SvREFCNT_dec(sv);
2482                     }
2483                 }
2484                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2485                           && !SvMAGICAL(*SP)) {
2486                     *++newsp = *SP;
2487                 }
2488                 else
2489                     *++newsp = sv_mortalcopy(*SP);
2490             }
2491             else
2492                 *++newsp = sv_mortalcopy(*SP);
2493         }
2494         else
2495             *++newsp = &PL_sv_undef;
2496       }
2497       else if (gimme == G_ARRAY) {
2498         while (++MARK <= SP) {
2499             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2500                                && !SvGMAGICAL(*MARK)
2501                         ? *MARK : sv_mortalcopy(*MARK);
2502             TAINT_NOT;          /* Each item is independent */
2503         }
2504       }
2505       PL_stack_sp = newsp;
2506     }
2507
2508     LEAVE;
2509     /* Stack values are safe: */
2510     if (popsub2) {
2511         cxstack_ix--;
2512         POPSUB(cx,sv);  /* release CV and @_ ... */
2513     }
2514     else
2515         sv = NULL;
2516     PL_curpm = newpm;   /* ... and pop $1 et al */
2517
2518     LEAVESUB(sv);
2519     if (clear_errsv) {
2520         CLEAR_ERRSV();
2521     }
2522     return retop;
2523 }
2524
2525 /* This duplicates parts of pp_leavesub, so that it can share code with
2526  * pp_return */
2527 PP(pp_leavesublv)
2528 {
2529     dVAR; dSP;
2530     SV **newsp;
2531     PMOP *newpm;
2532     I32 gimme;
2533     PERL_CONTEXT *cx;
2534     SV *sv;
2535
2536     if (CxMULTICALL(&cxstack[cxstack_ix]))
2537         return 0;
2538
2539     POPBLOCK(cx,newpm);
2540     cxstack_ix++; /* temporarily protect top context */
2541
2542     TAINT_NOT;
2543
2544     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2545
2546     LEAVE;
2547     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2548     cxstack_ix--;
2549     PL_curpm = newpm;   /* ... and pop $1 et al */
2550
2551     LEAVESUB(sv);
2552     return cx->blk_sub.retop;
2553 }
2554
2555 static I32
2556 S_unwind_loop(pTHX_ const char * const opname)
2557 {
2558     dVAR;
2559     I32 cxix;
2560     if (PL_op->op_flags & OPf_SPECIAL) {
2561         cxix = dopoptoloop(cxstack_ix);
2562         if (cxix < 0)
2563             /* diag_listed_as: Can't "last" outside a loop block */
2564             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2565     }
2566     else {
2567         dSP;
2568         STRLEN label_len;
2569         const char * const label =
2570             PL_op->op_flags & OPf_STACKED
2571                 ? SvPV(TOPs,label_len)
2572                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2573         const U32 label_flags =
2574             PL_op->op_flags & OPf_STACKED
2575                 ? SvUTF8(POPs)
2576                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2577         PUTBACK;
2578         cxix = dopoptolabel(label, label_len, label_flags);
2579         if (cxix < 0)
2580             /* diag_listed_as: Label not found for "last %s" */
2581             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2582                                        opname,
2583                                        SVfARG(PL_op->op_flags & OPf_STACKED
2584                                               && !SvGMAGICAL(TOPp1s)
2585                                               ? TOPp1s
2586                                               : newSVpvn_flags(label,
2587                                                     label_len,
2588                                                     label_flags | SVs_TEMP)));
2589     }
2590     if (cxix < cxstack_ix)
2591         dounwind(cxix);
2592     return cxix;
2593 }
2594
2595 PP(pp_last)
2596 {
2597     dVAR;
2598     PERL_CONTEXT *cx;
2599     I32 pop2 = 0;
2600     I32 gimme;
2601     I32 optype;
2602     OP *nextop = NULL;
2603     SV **newsp;
2604     PMOP *newpm;
2605     SV *sv = NULL;
2606
2607     S_unwind_loop(aTHX_ "last");
2608
2609     POPBLOCK(cx,newpm);
2610     cxstack_ix++; /* temporarily protect top context */
2611     switch (CxTYPE(cx)) {
2612     case CXt_LOOP_LAZYIV:
2613     case CXt_LOOP_LAZYSV:
2614     case CXt_LOOP_FOR:
2615     case CXt_LOOP_PLAIN:
2616         pop2 = CxTYPE(cx);
2617         newsp = PL_stack_base + cx->blk_loop.resetsp;
2618         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2619         break;
2620     case CXt_SUB:
2621         pop2 = CXt_SUB;
2622         nextop = cx->blk_sub.retop;
2623         break;
2624     case CXt_EVAL:
2625         POPEVAL(cx);
2626         nextop = cx->blk_eval.retop;
2627         break;
2628     case CXt_FORMAT:
2629         POPFORMAT(cx);
2630         nextop = cx->blk_sub.retop;
2631         break;
2632     default:
2633         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2634     }
2635
2636     TAINT_NOT;
2637     PL_stack_sp = newsp;
2638
2639     LEAVE;
2640     cxstack_ix--;
2641     /* Stack values are safe: */
2642     switch (pop2) {
2643     case CXt_LOOP_LAZYIV:
2644     case CXt_LOOP_PLAIN:
2645     case CXt_LOOP_LAZYSV:
2646     case CXt_LOOP_FOR:
2647         POPLOOP(cx);    /* release loop vars ... */
2648         LEAVE;
2649         break;
2650     case CXt_SUB:
2651         POPSUB(cx,sv);  /* release CV and @_ ... */
2652         break;
2653     }
2654     PL_curpm = newpm;   /* ... and pop $1 et al */
2655
2656     LEAVESUB(sv);
2657     PERL_UNUSED_VAR(optype);
2658     PERL_UNUSED_VAR(gimme);
2659     return nextop;
2660 }
2661
2662 PP(pp_next)
2663 {
2664     dVAR;
2665     PERL_CONTEXT *cx;
2666     const I32 inner = PL_scopestack_ix;
2667
2668     S_unwind_loop(aTHX_ "next");
2669
2670     /* clear off anything above the scope we're re-entering, but
2671      * save the rest until after a possible continue block */
2672     TOPBLOCK(cx);
2673     if (PL_scopestack_ix < inner)
2674         leave_scope(PL_scopestack[PL_scopestack_ix]);
2675     PL_curcop = cx->blk_oldcop;
2676     PERL_ASYNC_CHECK();
2677     return (cx)->blk_loop.my_op->op_nextop;
2678 }
2679
2680 PP(pp_redo)
2681 {
2682     dVAR;
2683     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2684     PERL_CONTEXT *cx;
2685     I32 oldsave;
2686     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2687
2688     if (redo_op->op_type == OP_ENTER) {
2689         /* pop one less context to avoid $x being freed in while (my $x..) */
2690         cxstack_ix++;
2691         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2692         redo_op = redo_op->op_next;
2693     }
2694
2695     TOPBLOCK(cx);
2696     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2697     LEAVE_SCOPE(oldsave);
2698     FREETMPS;
2699     PL_curcop = cx->blk_oldcop;
2700     PERL_ASYNC_CHECK();
2701     return redo_op;
2702 }
2703
2704 STATIC OP *
2705 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2706 {
2707     dVAR;
2708     OP **ops = opstack;
2709     static const char* const too_deep = "Target of goto is too deeply nested";
2710
2711     PERL_ARGS_ASSERT_DOFINDLABEL;
2712
2713     if (ops >= oplimit)
2714         Perl_croak(aTHX_ "%s", too_deep);
2715     if (o->op_type == OP_LEAVE ||
2716         o->op_type == OP_SCOPE ||
2717         o->op_type == OP_LEAVELOOP ||
2718         o->op_type == OP_LEAVESUB ||
2719         o->op_type == OP_LEAVETRY)
2720     {
2721         *ops++ = cUNOPo->op_first;
2722         if (ops >= oplimit)
2723             Perl_croak(aTHX_ "%s", too_deep);
2724     }
2725     *ops = 0;
2726     if (o->op_flags & OPf_KIDS) {
2727         OP *kid;
2728         /* First try all the kids at this level, since that's likeliest. */
2729         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2730             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2731                 STRLEN kid_label_len;
2732                 U32 kid_label_flags;
2733                 const char *kid_label = CopLABEL_len_flags(kCOP,
2734                                                     &kid_label_len, &kid_label_flags);
2735                 if (kid_label && (
2736                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2737                         (flags & SVf_UTF8)
2738                             ? (bytes_cmp_utf8(
2739                                         (const U8*)kid_label, kid_label_len,
2740                                         (const U8*)label, len) == 0)
2741                             : (bytes_cmp_utf8(
2742                                         (const U8*)label, len,
2743                                         (const U8*)kid_label, kid_label_len) == 0)
2744                     : ( len == kid_label_len && ((kid_label == label)
2745                                     || memEQ(kid_label, label, len)))))
2746                     return kid;
2747             }
2748         }
2749         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2750             if (kid == PL_lastgotoprobe)
2751                 continue;
2752             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2753                 if (ops == opstack)
2754                     *ops++ = kid;
2755                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2756                          ops[-1]->op_type == OP_DBSTATE)
2757                     ops[-1] = kid;
2758                 else
2759                     *ops++ = kid;
2760             }
2761             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2762                 return o;
2763         }
2764     }
2765     *ops = 0;
2766     return 0;
2767 }
2768
2769 PP(pp_goto) /* also pp_dump */
2770 {
2771     dVAR; dSP;
2772     OP *retop = NULL;
2773     I32 ix;
2774     PERL_CONTEXT *cx;
2775 #define GOTO_DEPTH 64
2776     OP *enterops[GOTO_DEPTH];
2777     const char *label = NULL;
2778     STRLEN label_len = 0;
2779     U32 label_flags = 0;
2780     const bool do_dump = (PL_op->op_type == OP_DUMP);
2781     static const char* const must_have_label = "goto must have label";
2782
2783     if (PL_op->op_flags & OPf_STACKED) {
2784         /* goto EXPR  or  goto &foo */
2785
2786         SV * const sv = POPs;
2787         SvGETMAGIC(sv);
2788
2789         /* This egregious kludge implements goto &subroutine */
2790         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2791             I32 cxix;
2792             PERL_CONTEXT *cx;
2793             CV *cv = MUTABLE_CV(SvRV(sv));
2794             AV *arg = GvAV(PL_defgv);
2795             I32 oldsave;
2796
2797         retry:
2798             if (!CvROOT(cv) && !CvXSUB(cv)) {
2799                 const GV * const gv = CvGV(cv);
2800                 if (gv) {
2801                     GV *autogv;
2802                     SV *tmpstr;
2803                     /* autoloaded stub? */
2804                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2805                         goto retry;
2806                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2807                                           GvNAMELEN(gv),
2808                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2809                     if (autogv && (cv = GvCV(autogv)))
2810                         goto retry;
2811                     tmpstr = sv_newmortal();
2812                     gv_efullname3(tmpstr, gv, NULL);
2813                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2814                 }
2815                 DIE(aTHX_ "Goto undefined subroutine");
2816             }
2817
2818             /* First do some returnish stuff. */
2819             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2820             FREETMPS;
2821             cxix = dopoptosub(cxstack_ix);
2822             if (cxix < cxstack_ix) {
2823                 if (cxix < 0) {
2824                     SvREFCNT_dec(cv);
2825                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2826                 }
2827                 dounwind(cxix);
2828             }
2829             TOPBLOCK(cx);
2830             SPAGAIN;
2831             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2832             if (CxTYPE(cx) == CXt_EVAL) {
2833                 SvREFCNT_dec(cv);
2834                 if (CxREALEVAL(cx))
2835                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2836                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2837                 else
2838                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2839                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2840             }
2841             else if (CxMULTICALL(cx))
2842             {
2843                 SvREFCNT_dec(cv);
2844                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2845             }
2846             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2847                 AV* av = cx->blk_sub.argarray;
2848
2849                 /* abandon the original @_ if it got reified or if it is
2850                    the same as the current @_ */
2851                 if (AvREAL(av) || av == arg) {
2852                     SvREFCNT_dec(av);
2853                     av = newAV();
2854                     AvREIFY_only(av);
2855                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2856                 }
2857                 else CLEAR_ARGARRAY(av);
2858             }
2859             /* We donate this refcount later to the callee’s pad. */
2860             SvREFCNT_inc_simple_void(arg);
2861             if (CxTYPE(cx) == CXt_SUB &&
2862                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2863                 SvREFCNT_dec(cx->blk_sub.cv);
2864             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2865             LEAVE_SCOPE(oldsave);
2866
2867             /* A destructor called during LEAVE_SCOPE could have undefined
2868              * our precious cv.  See bug #99850. */
2869             if (!CvROOT(cv) && !CvXSUB(cv)) {
2870                 const GV * const gv = CvGV(cv);
2871                 SvREFCNT_dec(arg);
2872                 if (gv) {
2873                     SV * const tmpstr = sv_newmortal();
2874                     gv_efullname3(tmpstr, gv, NULL);
2875                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2876                                SVfARG(tmpstr));
2877                 }
2878                 DIE(aTHX_ "Goto undefined subroutine");
2879             }
2880
2881             /* Now do some callish stuff. */
2882             SAVETMPS;
2883             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2884             if (CvISXSUB(cv)) {
2885                 OP* const retop = cx->blk_sub.retop;
2886                 SV **newsp;
2887                 I32 gimme;
2888                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2889                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2890                 SV** mark;
2891
2892                 PERL_UNUSED_VAR(newsp);
2893                 PERL_UNUSED_VAR(gimme);
2894
2895                 /* put GvAV(defgv) back onto stack */
2896                 if (items) {
2897                     EXTEND(SP, items+1); /* @_ could have been extended. */
2898                 }
2899                 mark = SP;
2900                 if (items) {
2901                     SSize_t index;
2902                     bool r = cBOOL(AvREAL(arg));
2903                     for (index=0; index<items; index++)
2904                     {
2905                         SV *sv;
2906                         if (m) {
2907                             SV ** const svp = av_fetch(arg, index, 0);
2908                             sv = svp ? *svp : NULL;
2909                         }
2910                         else sv = AvARRAY(arg)[index];
2911                         SP[index+1] = sv
2912                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2913                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2914                     }
2915                 }
2916                 SP += items;
2917                 SvREFCNT_dec(arg);
2918                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2919                     /* Restore old @_ */
2920                     arg = GvAV(PL_defgv);
2921                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2922                     SvREFCNT_dec(arg);
2923                 }
2924
2925                 /* XS subs don't have a CxSUB, so pop it */
2926                 POPBLOCK(cx, PL_curpm);
2927                 /* Push a mark for the start of arglist */
2928                 PUSHMARK(mark);
2929                 PUTBACK;
2930                 (void)(*CvXSUB(cv))(aTHX_ cv);
2931                 LEAVE;
2932                 PERL_ASYNC_CHECK();
2933                 return retop;
2934             }
2935             else {
2936                 PADLIST * const padlist = CvPADLIST(cv);
2937                 cx->blk_sub.cv = cv;
2938                 cx->blk_sub.olddepth = CvDEPTH(cv);
2939
2940                 CvDEPTH(cv)++;
2941                 if (CvDEPTH(cv) < 2)
2942                     SvREFCNT_inc_simple_void_NN(cv);
2943                 else {
2944                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2945                         sub_crush_depth(cv);
2946                     pad_push(padlist, CvDEPTH(cv));
2947                 }
2948                 PL_curcop = cx->blk_oldcop;
2949                 SAVECOMPPAD();
2950                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2951                 if (CxHASARGS(cx))
2952                 {
2953                     CX_CURPAD_SAVE(cx->blk_sub);
2954
2955                     /* cx->blk_sub.argarray has no reference count, so we
2956                        need something to hang on to our argument array so
2957                        that cx->blk_sub.argarray does not end up pointing
2958                        to freed memory as the result of undef *_.  So put
2959                        it in the callee’s pad, donating our refer-
2960                        ence count. */
2961                     if (arg) {
2962                         SvREFCNT_dec(PAD_SVl(0));
2963                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2964                     }
2965
2966                     /* GvAV(PL_defgv) might have been modified on scope
2967                        exit, so restore it. */
2968                     if (arg != GvAV(PL_defgv)) {
2969                         AV * const av = GvAV(PL_defgv);
2970                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2971                         SvREFCNT_dec(av);
2972                     }
2973                 }
2974                 else SvREFCNT_dec(arg);
2975                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2976                     Perl_get_db_sub(aTHX_ NULL, cv);
2977                     if (PERLDB_GOTO) {
2978                         CV * const gotocv = get_cvs("DB::goto", 0);
2979                         if (gotocv) {
2980                             PUSHMARK( PL_stack_sp );
2981                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2982                             PL_stack_sp--;
2983                         }
2984                     }
2985                 }
2986                 PERL_ASYNC_CHECK();
2987                 RETURNOP(CvSTART(cv));
2988             }
2989         }
2990         else {
2991             /* goto EXPR */
2992             label       = SvPV_nomg_const(sv, label_len);
2993             label_flags = SvUTF8(sv);
2994         }
2995     }
2996     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2997         /* goto LABEL  or  dump LABEL */
2998         label       = cPVOP->op_pv;
2999         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3000         label_len   = strlen(label);
3001     }
3002     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3003
3004     PERL_ASYNC_CHECK();
3005
3006     if (label_len) {
3007         OP *gotoprobe = NULL;
3008         bool leaving_eval = FALSE;
3009         bool in_block = FALSE;
3010         PERL_CONTEXT *last_eval_cx = NULL;
3011
3012         /* find label */
3013
3014         PL_lastgotoprobe = NULL;
3015         *enterops = 0;
3016         for (ix = cxstack_ix; ix >= 0; ix--) {
3017             cx = &cxstack[ix];
3018             switch (CxTYPE(cx)) {
3019             case CXt_EVAL:
3020                 leaving_eval = TRUE;
3021                 if (!CxTRYBLOCK(cx)) {
3022                     gotoprobe = (last_eval_cx ?
3023                                 last_eval_cx->blk_eval.old_eval_root :
3024                                 PL_eval_root);
3025                     last_eval_cx = cx;
3026                     break;
3027                 }
3028                 /* else fall through */
3029             case CXt_LOOP_LAZYIV:
3030             case CXt_LOOP_LAZYSV:
3031             case CXt_LOOP_FOR:
3032             case CXt_LOOP_PLAIN:
3033             case CXt_GIVEN:
3034             case CXt_WHEN:
3035                 gotoprobe = cx->blk_oldcop->op_sibling;
3036                 break;
3037             case CXt_SUBST:
3038                 continue;
3039             case CXt_BLOCK:
3040                 if (ix) {
3041                     gotoprobe = cx->blk_oldcop->op_sibling;
3042                     in_block = TRUE;
3043                 } else
3044                     gotoprobe = PL_main_root;
3045                 break;
3046             case CXt_SUB:
3047                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3048                     gotoprobe = CvROOT(cx->blk_sub.cv);
3049                     break;
3050                 }
3051                 /* FALLTHROUGH */
3052             case CXt_FORMAT:
3053             case CXt_NULL:
3054                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3055             default:
3056                 if (ix)
3057                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3058                         CxTYPE(cx), (long) ix);
3059                 gotoprobe = PL_main_root;
3060                 break;
3061             }
3062             if (gotoprobe) {
3063                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3064                                     enterops, enterops + GOTO_DEPTH);
3065                 if (retop)
3066                     break;
3067                 if (gotoprobe->op_sibling &&
3068                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3069                         gotoprobe->op_sibling->op_sibling) {
3070                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3071                                         label, label_len, label_flags, enterops,
3072                                         enterops + GOTO_DEPTH);
3073                     if (retop)
3074                         break;
3075                 }
3076             }
3077             PL_lastgotoprobe = gotoprobe;
3078         }
3079         if (!retop)
3080             DIE(aTHX_ "Can't find label %"UTF8f,
3081                        UTF8fARG(label_flags, label_len, label));
3082
3083         /* if we're leaving an eval, check before we pop any frames
3084            that we're not going to punt, otherwise the error
3085            won't be caught */
3086
3087         if (leaving_eval && *enterops && enterops[1]) {
3088             I32 i;
3089             for (i = 1; enterops[i]; i++)
3090                 if (enterops[i]->op_type == OP_ENTERITER)
3091                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3092         }
3093
3094         if (*enterops && enterops[1]) {
3095             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3096             if (enterops[i])
3097                 deprecate("\"goto\" to jump into a construct");
3098         }
3099
3100         /* pop unwanted frames */
3101
3102         if (ix < cxstack_ix) {
3103             I32 oldsave;
3104
3105             if (ix < 0)
3106                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3107             dounwind(ix);
3108             TOPBLOCK(cx);
3109             oldsave = PL_scopestack[PL_scopestack_ix];
3110             LEAVE_SCOPE(oldsave);
3111         }
3112
3113         /* push wanted frames */
3114
3115         if (*enterops && enterops[1]) {
3116             OP * const oldop = PL_op;
3117             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3118             for (; enterops[ix]; ix++) {
3119                 PL_op = enterops[ix];
3120                 /* Eventually we may want to stack the needed arguments
3121                  * for each op.  For now, we punt on the hard ones. */
3122                 if (PL_op->op_type == OP_ENTERITER)
3123                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3124                 PL_op->op_ppaddr(aTHX);
3125             }
3126             PL_op = oldop;
3127         }
3128     }
3129
3130     if (do_dump) {
3131 #ifdef VMS
3132         if (!retop) retop = PL_main_start;
3133 #endif
3134         PL_restartop = retop;
3135         PL_do_undump = TRUE;
3136
3137         my_unexec();
3138
3139         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3140         PL_do_undump = FALSE;
3141     }
3142
3143     PERL_ASYNC_CHECK();
3144     RETURNOP(retop);
3145 }
3146
3147 PP(pp_exit)
3148 {
3149     dVAR;
3150     dSP;
3151     I32 anum;
3152
3153     if (MAXARG < 1)
3154         anum = 0;
3155     else if (!TOPs) {
3156         anum = 0; (void)POPs;
3157     }
3158     else {
3159         anum = SvIVx(POPs);
3160 #ifdef VMS
3161         if (anum == 1
3162          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3163             anum = 0;
3164         VMSISH_HUSHED  =
3165             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3166 #endif
3167     }
3168     PL_exit_flags |= PERL_EXIT_EXPECTED;
3169     my_exit(anum);
3170     PUSHs(&PL_sv_undef);
3171     RETURN;
3172 }
3173
3174 /* Eval. */
3175
3176 STATIC void
3177 S_save_lines(pTHX_ AV *array, SV *sv)
3178 {
3179     const char *s = SvPVX_const(sv);
3180     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3181     I32 line = 1;
3182
3183     PERL_ARGS_ASSERT_SAVE_LINES;
3184
3185     while (s && s < send) {
3186         const char *t;
3187         SV * const tmpstr = newSV_type(SVt_PVMG);
3188
3189         t = (const char *)memchr(s, '\n', send - s);
3190         if (t)
3191             t++;
3192         else
3193             t = send;
3194
3195         sv_setpvn(tmpstr, s, t - s);
3196         av_store(array, line++, tmpstr);
3197         s = t;
3198     }
3199 }
3200
3201 /*
3202 =for apidoc docatch
3203
3204 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3205
3206 0 is used as continue inside eval,
3207
3208 3 is used for a die caught by an inner eval - continue inner loop
3209
3210 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3211 establish a local jmpenv to handle exception traps.
3212
3213 =cut
3214 */
3215 STATIC OP *
3216 S_docatch(pTHX_ OP *o)
3217 {
3218     dVAR;
3219     int ret;
3220     OP * const oldop = PL_op;
3221     dJMPENV;
3222
3223 #ifdef DEBUGGING
3224     assert(CATCH_GET == TRUE);
3225 #endif
3226     PL_op = o;
3227
3228     JMPENV_PUSH(ret);
3229     switch (ret) {
3230     case 0:
3231         assert(cxstack_ix >= 0);
3232         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3233         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3234  redo_body:
3235         CALLRUNOPS(aTHX);
3236         break;
3237     case 3:
3238         /* die caught by an inner eval - continue inner loop */
3239         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3240             PL_restartjmpenv = NULL;
3241             PL_op = PL_restartop;
3242             PL_restartop = 0;
3243             goto redo_body;
3244         }
3245         /* FALLTHROUGH */
3246     default:
3247         JMPENV_POP;
3248         PL_op = oldop;
3249         JMPENV_JUMP(ret);
3250         assert(0); /* NOTREACHED */
3251     }
3252     JMPENV_POP;
3253     PL_op = oldop;
3254     return NULL;
3255 }
3256
3257
3258 /*
3259 =for apidoc find_runcv
3260
3261 Locate the CV corresponding to the currently executing sub or eval.
3262 If db_seqp is non_null, skip CVs that are in the DB package and populate
3263 *db_seqp with the cop sequence number at the point that the DB:: code was
3264 entered.  (This allows debuggers to eval in the scope of the breakpoint
3265 rather than in the scope of the debugger itself.)
3266
3267 =cut
3268 */
3269
3270 CV*
3271 Perl_find_runcv(pTHX_ U32 *db_seqp)
3272 {
3273     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3274 }
3275
3276 /* If this becomes part of the API, it might need a better name. */
3277 CV *
3278 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3279 {
3280     dVAR;
3281     PERL_SI      *si;
3282     int          level = 0;
3283
3284     if (db_seqp)
3285         *db_seqp =
3286             PL_curcop == &PL_compiling
3287                 ? PL_cop_seqmax
3288                 : PL_curcop->cop_seq;
3289
3290     for (si = PL_curstackinfo; si; si = si->si_prev) {
3291         I32 ix;
3292         for (ix = si->si_cxix; ix >= 0; ix--) {
3293             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3294             CV *cv = NULL;
3295             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3296                 cv = cx->blk_sub.cv;
3297                 /* skip DB:: code */
3298                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3299                     *db_seqp = cx->blk_oldcop->cop_seq;
3300                     continue;
3301                 }
3302                 if (cx->cx_type & CXp_SUB_RE)
3303                     continue;
3304             }
3305             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3306                 cv = cx->blk_eval.cv;
3307             if (cv) {
3308                 switch (cond) {
3309                 case FIND_RUNCV_padid_eq:
3310                     if (!CvPADLIST(cv)
3311                      || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3312                         continue;
3313                     return cv;
3314                 case FIND_RUNCV_level_eq:
3315                     if (level++ != arg) continue;
3316                     /* GERONIMO! */
3317                 default:
3318                     return cv;
3319                 }
3320             }
3321         }
3322     }
3323     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3324 }
3325
3326
3327 /* Run yyparse() in a setjmp wrapper. Returns:
3328  *   0: yyparse() successful
3329  *   1: yyparse() failed
3330  *   3: yyparse() died
3331  */
3332 STATIC int
3333 S_try_yyparse(pTHX_ int gramtype)
3334 {
3335     int ret;
3336     dJMPENV;
3337
3338     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3339     JMPENV_PUSH(ret);
3340     switch (ret) {
3341     case 0:
3342         ret = yyparse(gramtype) ? 1 : 0;
3343         break;
3344     case 3:
3345         break;
3346     default:
3347         JMPENV_POP;
3348         JMPENV_JUMP(ret);
3349         assert(0); /* NOTREACHED */
3350     }
3351     JMPENV_POP;
3352     return ret;
3353 }
3354
3355
3356 /* Compile a require/do or an eval ''.
3357  *
3358  * outside is the lexically enclosing CV (if any) that invoked us.
3359  * seq     is the current COP scope value.
3360  * hh      is the saved hints hash, if any.
3361  *
3362  * Returns a bool indicating whether the compile was successful; if so,
3363  * PL_eval_start contains the first op of the compiled code; otherwise,
3364  * pushes undef.
3365  *
3366  * This function is called from two places: pp_require and pp_entereval.
3367  * These can be distinguished by whether PL_op is entereval.
3368  */
3369
3370 STATIC bool
3371 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3372 {
3373     dVAR; dSP;
3374     OP * const saveop = PL_op;
3375     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3376     COP * const oldcurcop = PL_curcop;
3377     bool in_require = (saveop->op_type == OP_REQUIRE);
3378     int yystatus;
3379     CV *evalcv;
3380
3381     PL_in_eval = (in_require
3382                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3383                   : (EVAL_INEVAL |
3384                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3385                             ? EVAL_RE_REPARSING : 0)));
3386
3387     PUSHMARK(SP);
3388
3389     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3390     CvEVAL_on(evalcv);
3391     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3392     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3393     cxstack[cxstack_ix].blk_gimme = gimme;
3394
3395     CvOUTSIDE_SEQ(evalcv) = seq;
3396     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3397
3398     /* set up a scratch pad */
3399
3400     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3401     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3402
3403
3404     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3405
3406     /* make sure we compile in the right package */
3407
3408     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3409         SAVEGENERICSV(PL_curstash);
3410         PL_curstash = (HV *)CopSTASH(PL_curcop);
3411         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3412         else SvREFCNT_inc_simple_void(PL_curstash);
3413     }
3414     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3415     SAVESPTR(PL_beginav);
3416     PL_beginav = newAV();
3417     SAVEFREESV(PL_beginav);
3418     SAVESPTR(PL_unitcheckav);
3419     PL_unitcheckav = newAV();
3420     SAVEFREESV(PL_unitcheckav);
3421
3422
3423     ENTER_with_name("evalcomp");
3424     SAVESPTR(PL_compcv);
3425     PL_compcv = evalcv;
3426
3427     /* try to compile it */
3428
3429     PL_eval_root = NULL;
3430     PL_curcop = &PL_compiling;
3431     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3432         PL_in_eval |= EVAL_KEEPERR;
3433     else
3434         CLEAR_ERRSV();
3435
3436     SAVEHINTS();
3437     if (clear_hints) {
3438         PL_hints = 0;
3439         hv_clear(GvHV(PL_hintgv));
3440     }
3441     else {
3442         PL_hints = saveop->op_private & OPpEVAL_COPHH
3443                      ? oldcurcop->cop_hints : saveop->op_targ;
3444
3445         /* making 'use re eval' not be in scope when compiling the
3446          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3447          * infinite recursion when S_has_runtime_code() gives a false
3448          * positive: the second time round, HINT_RE_EVAL isn't set so we
3449          * don't bother calling S_has_runtime_code() */
3450         if (PL_in_eval & EVAL_RE_REPARSING)
3451             PL_hints &= ~HINT_RE_EVAL;
3452
3453         if (hh) {
3454             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3455             SvREFCNT_dec(GvHV(PL_hintgv));
3456             GvHV(PL_hintgv) = hh;
3457         }
3458     }
3459     SAVECOMPILEWARNINGS();
3460     if (clear_hints) {
3461         if (PL_dowarn & G_WARN_ALL_ON)
3462             PL_compiling.cop_warnings = pWARN_ALL ;
3463         else if (PL_dowarn & G_WARN_ALL_OFF)
3464             PL_compiling.cop_warnings = pWARN_NONE ;
3465         else
3466             PL_compiling.cop_warnings = pWARN_STD ;
3467     }
3468     else {
3469         PL_compiling.cop_warnings =
3470             DUP_WARNINGS(oldcurcop->cop_warnings);
3471         cophh_free(CopHINTHASH_get(&PL_compiling));
3472         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3473             /* The label, if present, is the first entry on the chain. So rather
3474                than writing a blank label in front of it (which involves an
3475                allocation), just use the next entry in the chain.  */
3476             PL_compiling.cop_hints_hash
3477                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3478             /* Check the assumption that this removed the label.  */
3479             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3480         }
3481         else
3482             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3483     }
3484
3485     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3486
3487     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3488      * so honour CATCH_GET and trap it here if necessary */
3489
3490     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3491
3492     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3493         SV **newsp;                     /* Used by POPBLOCK. */
3494         PERL_CONTEXT *cx;
3495         I32 optype;                     /* Used by POPEVAL. */
3496         SV *namesv;
3497         SV *errsv = NULL;
3498
3499         cx = NULL;
3500         namesv = NULL;
3501         PERL_UNUSED_VAR(newsp);
3502         PERL_UNUSED_VAR(optype);
3503
3504         /* note that if yystatus == 3, then the EVAL CX block has already
3505          * been popped, and various vars restored */
3506         PL_op = saveop;
3507         if (yystatus != 3) {
3508             if (PL_eval_root) {
3509                 op_free(PL_eval_root);
3510                 PL_eval_root = NULL;
3511             }
3512             SP = PL_stack_base + POPMARK;       /* pop original mark */
3513             POPBLOCK(cx,PL_curpm);
3514             POPEVAL(cx);
3515             namesv = cx->blk_eval.old_namesv;
3516             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3517             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3518         }
3519
3520         errsv = ERRSV;
3521         if (in_require) {
3522             if (!cx) {
3523                 /* If cx is still NULL, it means that we didn't go in the
3524                  * POPEVAL branch. */
3525                 cx = &cxstack[cxstack_ix];
3526                 assert(CxTYPE(cx) == CXt_EVAL);
3527                 namesv = cx->blk_eval.old_namesv;
3528             }
3529             (void)hv_store(GvHVn(PL_incgv),
3530                            SvPVX_const(namesv),
3531                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3532                            &PL_sv_undef, 0);
3533             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3534                        SVfARG(errsv
3535                                 ? errsv
3536                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3537         }
3538         else {
3539             if (!*(SvPV_nolen_const(errsv))) {
3540                 sv_setpvs(errsv, "Compilation error");
3541             }
3542         }
3543         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3544         PUTBACK;
3545         return FALSE;
3546     }
3547     else
3548         LEAVE_with_name("evalcomp");
3549
3550     CopLINE_set(&PL_compiling, 0);
3551     SAVEFREEOP(PL_eval_root);
3552     cv_forget_slab(evalcv);
3553
3554     DEBUG_x(dump_eval());
3555
3556     /* Register with debugger: */
3557     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3558         CV * const cv = get_cvs("DB::postponed", 0);
3559         if (cv) {
3560             dSP;
3561             PUSHMARK(SP);
3562             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3563             PUTBACK;
3564             call_sv(MUTABLE_SV(cv), G_DISCARD);
3565         }
3566     }
3567
3568     if (PL_unitcheckav) {
3569         OP *es = PL_eval_start;
3570         call_list(PL_scopestack_ix, PL_unitcheckav);
3571         PL_eval_start = es;
3572     }
3573
3574     /* compiled okay, so do it */
3575
3576     CvDEPTH(evalcv) = 1;
3577     SP = PL_stack_base + POPMARK;               /* pop original mark */
3578     PL_op = saveop;                     /* The caller may need it. */
3579     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3580
3581     PUTBACK;
3582     return TRUE;
3583 }
3584
3585 STATIC PerlIO *
3586 S_check_type_and_open(pTHX_ SV *name)
3587 {
3588     Stat_t st;
3589     STRLEN len;
3590     const char *p = SvPV_const(name, len);
3591     int st_rc;
3592
3593     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3594
3595     /* checking here captures a reasonable error message when
3596      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3597      * user gets a confusing message about looking for the .pmc file
3598      * rather than for the .pm file.
3599      * This check prevents a \0 in @INC causing problems.
3600      */
3601     if (!IS_SAFE_PATHNAME(p, len, "require"))
3602         return NULL;
3603
3604     /* we use the value of errno later to see how stat() or open() failed.
3605      * We don't want it set if the stat succeeded but we still failed,
3606      * such as if the name exists, but is a directory */
3607     errno = 0;
3608
3609     st_rc = PerlLIO_stat(p, &st);
3610
3611     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3612         return NULL;
3613     }
3614
3615 #if !defined(PERLIO_IS_STDIO)
3616     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3617 #else
3618     return PerlIO_open(p, PERL_SCRIPT_MODE);
3619 #endif
3620 }
3621
3622 #ifndef PERL_DISABLE_PMC
3623 STATIC PerlIO *
3624 S_doopen_pm(pTHX_ SV *name)
3625 {
3626     STRLEN namelen;
3627     const char *p = SvPV_const(name, namelen);
3628
3629     PERL_ARGS_ASSERT_DOOPEN_PM;
3630
3631     /* check the name before trying for the .pmc name to avoid the
3632      * warning referring to the .pmc which the user probably doesn't
3633      * know or care about
3634      */
3635     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3636         return NULL;
3637
3638     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3639         SV *const pmcsv = sv_newmortal();
3640         Stat_t pmcstat;
3641
3642         SvSetSV_nosteal(pmcsv,name);
3643         sv_catpvs(pmcsv, "c");
3644
3645         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3646             return check_type_and_open(pmcsv);
3647     }
3648     return check_type_and_open(name);
3649 }
3650 #else
3651 #  define doopen_pm(name) check_type_and_open(name)
3652 #endif /* !PERL_DISABLE_PMC */
3653
3654 /* require doesn't search for absolute names, or when the name is
3655    explicity relative the current directory */
3656 PERL_STATIC_INLINE bool
3657 S_path_is_searchable(const char *name)
3658 {
3659     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3660
3661     if (PERL_FILE_IS_ABSOLUTE(name)
3662 #ifdef WIN32
3663         || (*name == '.' && ((name[1] == '/' ||
3664                              (name[1] == '.' && name[2] == '/'))
3665                          || (name[1] == '\\' ||
3666                              ( name[1] == '.' && name[2] == '\\')))
3667             )
3668 #else
3669         || (*name == '.' && (name[1] == '/' ||
3670                              (name[1] == '.' && name[2] == '/')))
3671 #endif
3672          )
3673     {
3674         return FALSE;
3675     }
3676     else
3677         return TRUE;
3678 }
3679
3680 PP(pp_require)
3681 {
3682     dVAR; dSP;
3683     PERL_CONTEXT *cx;
3684     SV *sv;
3685     const char *name;
3686     STRLEN len;
3687     char * unixname;
3688     STRLEN unixlen;
3689 #ifdef VMS
3690     int vms_unixname = 0;
3691     char *unixdir;
3692 #endif
3693     const char *tryname = NULL;
3694     SV *namesv = NULL;
3695     const I32 gimme = GIMME_V;
3696     int filter_has_file = 0;
3697     PerlIO *tryrsfp = NULL;
3698     SV *filter_cache = NULL;
3699     SV *filter_state = NULL;
3700     SV *filter_sub = NULL;
3701     SV *hook_sv = NULL;
3702     SV *encoding;
3703     OP *op;
3704     int saved_errno;
3705     bool path_searchable;
3706
3707     sv = POPs;
3708     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3709         sv = sv_2mortal(new_version(sv));
3710         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3711             upg_version(PL_patchlevel, TRUE);
3712         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3713             if ( vcmp(sv,PL_patchlevel) <= 0 )
3714                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3715                     SVfARG(sv_2mortal(vnormal(sv))),
3716                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3717                 );
3718         }
3719         else {
3720             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3721                 I32 first = 0;
3722                 AV *lav;
3723                 SV * const req = SvRV(sv);
3724                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3725
3726                 /* get the left hand term */
3727                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3728
3729                 first  = SvIV(*av_fetch(lav,0,0));
3730                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3731                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3732                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3733                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3734                    ) {
3735                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3736                         "%"SVf", stopped",
3737                         SVfARG(sv_2mortal(vnormal(req))),
3738                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3739                     );
3740                 }
3741                 else { /* probably 'use 5.10' or 'use 5.8' */
3742                     SV *hintsv;
3743                     I32 second = 0;
3744
3745                     if (av_tindex(lav)>=1)
3746                         second = SvIV(*av_fetch(lav,1,0));
3747
3748                     second /= second >= 600  ? 100 : 10;
3749                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3750                                            (int)first, (int)second);
3751                     upg_version(hintsv, TRUE);
3752
3753                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3754                         "--this is only %"SVf", stopped",
3755                         SVfARG(sv_2mortal(vnormal(req))),
3756                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3757                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3758                     );
3759                 }
3760             }
3761         }
3762
3763         RETPUSHYES;
3764     }
3765     name = SvPV_const(sv, len);
3766     if (!(name && len > 0 && *name))
3767         DIE(aTHX_ "Null filename used");
3768     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3769         DIE(aTHX_ "Can't locate %s:   %s",
3770             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3771                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3772             Strerror(ENOENT));
3773     }
3774     TAINT_PROPER("require");
3775
3776     path_searchable = path_is_searchable(name);
3777
3778 #ifdef VMS
3779     /* The key in the %ENV hash is in the syntax of file passed as the argument
3780      * usually this is in UNIX format, but sometimes in VMS format, which
3781      * can result in a module being pulled in more than once.
3782      * To prevent this, the key must be stored in UNIX format if the VMS
3783      * name can be translated to UNIX.
3784      */
3785
3786     if ((unixname =
3787           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3788          != NULL) {
3789         unixlen = strlen(unixname);
3790         vms_unixname = 1;
3791     }
3792     else
3793 #endif
3794     {
3795         /* if not VMS or VMS name can not be translated to UNIX, pass it
3796          * through.
3797          */
3798         unixname = (char *) name;
3799         unixlen = len;
3800     }
3801     if (PL_op->op_type == OP_REQUIRE) {
3802         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3803                                           unixname, unixlen, 0);
3804         if ( svp ) {
3805             if (*svp != &PL_sv_undef)
3806                 RETPUSHYES;
3807             else
3808                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3809                             "Compilation failed in require", unixname);
3810         }
3811     }
3812
3813     LOADING_FILE_PROBE(unixname);
3814
3815     /* prepare to compile file */
3816
3817     if (!path_searchable) {
3818         /* At this point, name is SvPVX(sv)  */
3819         tryname = name;
3820         tryrsfp = doopen_pm(sv);
3821     }
3822     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3823         AV * const ar = GvAVn(PL_incgv);
3824         SSize_t i;
3825 #ifdef VMS
3826         if (vms_unixname)
3827 #endif
3828         {
3829             SV *nsv = sv;
3830             namesv = newSV_type(SVt_PV);
3831             for (i = 0; i <= AvFILL(ar); i++) {
3832                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3833
3834                 SvGETMAGIC(dirsv);
3835                 if (SvROK(dirsv)) {
3836                     int count;
3837                     SV **svp;
3838                     SV *loader = dirsv;
3839
3840                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3841                         && !SvOBJECT(SvRV(loader)))
3842                     {
3843                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3844                         SvGETMAGIC(loader);
3845                     }
3846
3847                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3848                                    PTR2UV(SvRV(dirsv)), name);
3849                     tryname = SvPVX_const(namesv);
3850                     tryrsfp = NULL;
3851
3852                     if (SvPADTMP(nsv)) {
3853                         nsv = sv_newmortal();
3854                         SvSetSV_nosteal(nsv,sv);
3855                     }
3856
3857                     ENTER_with_name("call_INC");
3858                     SAVETMPS;
3859                     EXTEND(SP, 2);
3860
3861                     PUSHMARK(SP);
3862                     PUSHs(dirsv);
3863                     PUSHs(nsv);
3864                     PUTBACK;
3865                     if (SvGMAGICAL(loader)) {
3866                         SV *l = sv_newmortal();
3867                         sv_setsv_nomg(l, loader);
3868                         loader = l;
3869                     }
3870                     if (sv_isobject(loader))
3871                         count = call_method("INC", G_ARRAY);
3872                     else
3873                         count = call_sv(loader, G_ARRAY);
3874                     SPAGAIN;
3875
3876                     if (count > 0) {
3877                         int i = 0;
3878                         SV *arg;
3879
3880                         SP -= count - 1;
3881                         arg = SP[i++];
3882
3883                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3884                             && !isGV_with_GP(SvRV(arg))) {
3885                             filter_cache = SvRV(arg);
3886
3887                             if (i < count) {
3888                                 arg = SP[i++];
3889                             }
3890                         }
3891
3892                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3893                             arg = SvRV(arg);
3894                         }
3895
3896                         if (isGV_with_GP(arg)) {
3897                             IO * const io = GvIO((const GV *)arg);
3898
3899                             ++filter_has_file;
3900
3901                             if (io) {
3902                                 tryrsfp = IoIFP(io);
3903                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3904                                     PerlIO_close(IoOFP(io));
3905                                 }
3906                                 IoIFP(io) = NULL;
3907                                 IoOFP(io) = NULL;
3908                             }
3909
3910                             if (i < count) {
3911                                 arg = SP[i++];
3912                             }
3913                         }
3914
3915                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3916                             filter_sub = arg;
3917                             SvREFCNT_inc_simple_void_NN(filter_sub);
3918
3919                             if (i < count) {
3920                                 filter_state = SP[i];
3921                                 SvREFCNT_inc_simple_void(filter_state);
3922                             }
3923                         }
3924
3925                         if (!tryrsfp && (filter_cache || filter_sub)) {
3926                             tryrsfp = PerlIO_open(BIT_BUCKET,
3927                                                   PERL_SCRIPT_MODE);
3928                         }
3929                         SP--;
3930                     }
3931
3932                     /* FREETMPS may free our filter_cache */
3933                     SvREFCNT_inc_simple_void(filter_cache);
3934
3935                     PUTBACK;
3936                     FREETMPS;
3937                     LEAVE_with_name("call_INC");
3938
3939                     /* Now re-mortalize it. */
3940                     sv_2mortal(filter_cache);
3941
3942                     /* Adjust file name if the hook has set an %INC entry.
3943                        This needs to happen after the FREETMPS above.  */
3944                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3945                     if (svp)
3946                         tryname = SvPV_nolen_const(*svp);
3947
3948                     if (tryrsfp) {
3949                         hook_sv = dirsv;
3950                         break;
3951                     }
3952
3953                     filter_has_file = 0;
3954                     filter_cache = NULL;
3955                     if (filter_state) {
3956                         SvREFCNT_dec_NN(filter_state);
3957                         filter_state = NULL;
3958                     }
3959                     if (filter_sub) {
3960                         SvREFCNT_dec_NN(filter_sub);
3961                         filter_sub = NULL;
3962                     }
3963                 }
3964                 else {
3965                   if (path_searchable) {
3966                     const char *dir;
3967                     STRLEN dirlen;
3968
3969                     if (SvOK(dirsv)) {
3970                         dir = SvPV_nomg_const(dirsv, dirlen);
3971                     } else {
3972                         dir = "";
3973                         dirlen = 0;
3974                     }
3975
3976                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3977                         continue;
3978 #ifdef VMS
3979                     if ((unixdir =
3980                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3981                          == NULL)
3982                         continue;
3983                     sv_setpv(namesv, unixdir);
3984                     sv_catpv(namesv, unixname);
3985 #else
3986 #  ifdef __SYMBIAN32__
3987                     if (PL_origfilename[0] &&
3988                         PL_origfilename[1] == ':' &&
3989                         !(dir[0] && dir[1] == ':'))
3990                         Perl_sv_setpvf(aTHX_ namesv,
3991                                        "%c:%s\\%s",
3992                                        PL_origfilename[0],
3993                                        dir, name);
3994                     else
3995                         Perl_sv_setpvf(aTHX_ namesv,
3996                                        "%s\\%s",
3997                                        dir, name);
3998 #  else
3999                     /* The equivalent of
4000                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4001                        but without the need to parse the format string, or
4002                        call strlen on either pointer, and with the correct
4003                        allocation up front.  */
4004                     {
4005                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4006
4007                         memcpy(tmp, dir, dirlen);
4008                         tmp +=dirlen;
4009
4010                         /* Avoid '<dir>//<file>' */
4011                         if (!dirlen || *(tmp-1) != '/') {
4012                             *tmp++ = '/';
4013                         } else {
4014                             /* So SvCUR_set reports the correct length below */
4015                             dirlen--;
4016                         }
4017
4018                         /* name came from an SV, so it will have a '\0' at the
4019                            end that we can copy as part of this memcpy().  */
4020                         memcpy(tmp, name, len + 1);
4021
4022                         SvCUR_set(namesv, dirlen + len + 1);
4023                         SvPOK_on(namesv);
4024                     }
4025 #  endif
4026 #endif
4027                     TAINT_PROPER("require");
4028                     tryname = SvPVX_const(namesv);
4029                     tryrsfp = doopen_pm(namesv);
4030                     if (tryrsfp) {
4031                         if (tryname[0] == '.' && tryname[1] == '/') {
4032                             ++tryname;
4033                             while (*++tryname == '/') {}
4034                         }
4035                         break;
4036                     }
4037                     else if (errno == EMFILE || errno == EACCES) {
4038                         /* no point in trying other paths if out of handles;
4039                          * on the other hand, if we couldn't open one of the
4040                          * files, then going on with the search could lead to
4041                          * unexpected results; see perl #113422
4042                          */
4043                         break;
4044                     }
4045                   }
4046                 }
4047             }
4048         }
4049     }
4050     saved_errno = errno; /* sv_2mortal can realloc things */
4051     sv_2mortal(namesv);
4052     if (!tryrsfp) {
4053         if (PL_op->op_type == OP_REQUIRE) {
4054             if(saved_errno == EMFILE || saved_errno == EACCES) {
4055                 /* diag_listed_as: Can't locate %s */
4056                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
4057             } else {
4058                 if (namesv) {                   /* did we lookup @INC? */
4059                     AV * const ar = GvAVn(PL_incgv);
4060                     SSize_t i;
4061                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4062                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4063                     for (i = 0; i <= AvFILL(ar); i++) {
4064                         sv_catpvs(inc, " ");
4065                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4066                     }
4067                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4068                         const char *c, *e = name + len - 3;
4069                         sv_catpv(msg, " (you may need to install the ");
4070                         for (c = name; c < e; c++) {
4071                             if (*c == '/') {
4072                                 sv_catpvs(msg, "::");
4073                             }
4074                             else {
4075                                 sv_catpvn(msg, c, 1);
4076                             }
4077                         }
4078                         sv_catpv(msg, " module)");
4079                     }
4080                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4081                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4082                     }
4083                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4084                         sv_catpv(msg, " (did you run h2ph?)");
4085                     }
4086
4087                     /* diag_listed_as: Can't locate %s */
4088                     DIE(aTHX_
4089                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4090                         name, msg, inc);
4091                 }
4092             }
4093             DIE(aTHX_ "Can't locate %s", name);
4094         }
4095
4096         CLEAR_ERRSV();
4097         RETPUSHUNDEF;
4098     }
4099     else
4100         SETERRNO(0, SS_NORMAL);
4101
4102     /* Assume success here to prevent recursive requirement. */
4103     /* name is never assigned to again, so len is still strlen(name)  */
4104     /* Check whether a hook in @INC has already filled %INC */
4105     if (!hook_sv) {
4106         (void)hv_store(GvHVn(PL_incgv),
4107                        unixname, unixlen, newSVpv(tryname,0),0);
4108     } else {
4109         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4110         if (!svp)
4111             (void)hv_store(GvHVn(PL_incgv),
4112                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4113     }
4114
4115     ENTER_with_name("eval");
4116     SAVETMPS;
4117     SAVECOPFILE_FREE(&PL_compiling);
4118     CopFILE_set(&PL_compiling, tryname);
4119     lex_start(NULL, tryrsfp, 0);
4120
4121     if (filter_sub || filter_cache) {
4122         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4123            than hanging another SV from it. In turn, filter_add() optionally
4124            takes the SV to use as the filter (or creates a new SV if passed
4125            NULL), so simply pass in whatever value filter_cache has.  */
4126         SV * const fc = filter_cache ? newSV(0) : NULL;
4127         SV *datasv;
4128         if (fc) sv_copypv(fc, filter_cache);
4129         datasv = filter_add(S_run_user_filter, fc);
4130         IoLINES(datasv) = filter_has_file;
4131         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4132         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4133     }
4134
4135     /* switch to eval mode */
4136     PUSHBLOCK(cx, CXt_EVAL, SP);
4137     PUSHEVAL(cx, name);
4138     cx->blk_eval.retop = PL_op->op_next;
4139
4140     SAVECOPLINE(&PL_compiling);
4141     CopLINE_set(&PL_compiling, 0);
4142
4143     PUTBACK;
4144
4145     /* Store and reset encoding. */
4146     encoding = PL_encoding;
4147     PL_encoding = NULL;
4148
4149     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4150         op = DOCATCH(PL_eval_start);
4151     else
4152         op = PL_op->op_next;
4153
4154     /* Restore encoding. */
4155     PL_encoding = encoding;
4156
4157     LOADED_FILE_PROBE(unixname);
4158
4159     return op;
4160 }
4161
4162 /* This is a op added to hold the hints hash for
4163    pp_entereval. The hash can be modified by the code
4164    being eval'ed, so we return a copy instead. */
4165
4166 PP(pp_hintseval)
4167 {
4168     dVAR;
4169     dSP;
4170     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4171     RETURN;
4172 }
4173
4174
4175 PP(pp_entereval)
4176 {
4177     dVAR; dSP;
4178     PERL_CONTEXT *cx;
4179     SV *sv;
4180     const I32 gimme = GIMME_V;
4181     const U32 was = PL_breakable_sub_gen;
4182     char tbuf[TYPE_DIGITS(long) + 12];
4183     bool saved_delete = FALSE;
4184     char *tmpbuf = tbuf;
4185     STRLEN len;
4186     CV* runcv;
4187     U32 seq, lex_flags = 0;
4188     HV *saved_hh = NULL;
4189     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4190
4191     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4192         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4193     }
4194     else if (PL_hints & HINT_LOCALIZE_HH || (
4195                 PL_op->op_private & OPpEVAL_COPHH
4196              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4197             )) {
4198         saved_hh = cop_hints_2hv(PL_curcop, 0);
4199         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4200     }
4201     sv = POPs;
4202     if (!SvPOK(sv)) {
4203         /* make sure we've got a plain PV (no overload etc) before testing
4204          * for taint. Making a copy here is probably overkill, but better
4205          * safe than sorry */
4206         STRLEN len;
4207         const char * const p = SvPV_const(sv, len);
4208
4209         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4210         lex_flags |= LEX_START_COPIED;
4211
4212         if (bytes && SvUTF8(sv))
4213             SvPVbyte_force(sv, len);
4214     }
4215     else if (bytes && SvUTF8(sv)) {
4216         /* Don't modify someone else's scalar */
4217         STRLEN len;
4218         sv = newSVsv(sv);
4219         (void)sv_2mortal(sv);
4220         SvPVbyte_force(sv,len);
4221         lex_flags |= LEX_START_COPIED;
4222     }
4223
4224     TAINT_IF(SvTAINTED(sv));
4225     TAINT_PROPER("eval");
4226
4227     ENTER_with_name("eval");
4228     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4229                            ? LEX_IGNORE_UTF8_HINTS
4230                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4231                         )
4232              );
4233     SAVETMPS;
4234
4235     /* switch to eval mode */
4236
4237     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4238         SV * const temp_sv = sv_newmortal();
4239         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4240                        (unsigned long)++PL_evalseq,
4241                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4242         tmpbuf = SvPVX(temp_sv);
4243         len = SvCUR(temp_sv);
4244     }
4245     else
4246         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4247     SAVECOPFILE_FREE(&PL_compiling);
4248     CopFILE_set(&PL_compiling, tmpbuf+2);
4249     SAVECOPLINE(&PL_compiling);
4250     CopLINE_set(&PL_compiling, 1);
4251     /* special case: an eval '' executed within the DB package gets lexically
4252      * placed in the first non-DB CV rather than the current CV - this
4253      * allows the debugger to execute code, find lexicals etc, in the
4254      * scope of the code being debugged. Passing &seq gets find_runcv
4255      * to do the dirty work for us */
4256     runcv = find_runcv(&seq);
4257
4258     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4259     PUSHEVAL(cx, 0);
4260     cx->blk_eval.retop = PL_op->op_next;
4261
4262     /* prepare to compile string */
4263
4264     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4265         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4266     else {
4267         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4268            deleting the eval's FILEGV from the stash before gv_check() runs
4269            (i.e. before run-time proper). To work around the coredump that
4270            ensues, we always turn GvMULTI_on for any globals that were
4271            introduced within evals. See force_ident(). GSAR 96-10-12 */
4272         char *const safestr = savepvn(tmpbuf, len);
4273         SAVEDELETE(PL_defstash, safestr, len);
4274         saved_delete = TRUE;
4275     }
4276
4277     PUTBACK;
4278
4279     if (doeval(gimme, runcv, seq, saved_hh)) {
4280         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4281             ? (PERLDB_LINE || PERLDB_SAVESRC)
4282             :  PERLDB_SAVESRC_NOSUBS) {
4283             /* Retain the filegv we created.  */
4284         } else if (!saved_delete) {
4285             char *const safestr = savepvn(tmpbuf, len);
4286             SAVEDELETE(PL_defstash, safestr, len);
4287         }
4288         return DOCATCH(PL_eval_start);
4289     } else {
4290         /* We have already left the scope set up earlier thanks to the LEAVE
4291            in doeval().  */
4292         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4293             ? (PERLDB_LINE || PERLDB_SAVESRC)
4294             :  PERLDB_SAVESRC_INVALID) {
4295             /* Retain the filegv we created.  */
4296         } else if (!saved_delete) {
4297             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4298         }
4299         return PL_op->op_next;
4300     }
4301 }
4302
4303 PP(pp_leaveeval)
4304 {
4305     dVAR; dSP;
4306     SV **newsp;
4307     PMOP *newpm;
4308     I32 gimme;
4309     PERL_CONTEXT *cx;
4310     OP *retop;
4311     const U8 save_flags = PL_op -> op_flags;
4312     I32 optype;
4313     SV *namesv;
4314     CV *evalcv;
4315
4316     PERL_ASYNC_CHECK();
4317     POPBLOCK(cx,newpm);
4318     POPEVAL(cx);
4319     namesv = cx->blk_eval.old_namesv;
4320     retop = cx->blk_eval.retop;
4321     evalcv = cx->blk_eval.cv;
4322
4323     TAINT_NOT;
4324     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4325                                 gimme, SVs_TEMP, FALSE);
4326     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4327
4328 #ifdef DEBUGGING
4329     assert(CvDEPTH(evalcv) == 1);
4330 #endif
4331     CvDEPTH(evalcv) = 0;
4332
4333     if (optype == OP_REQUIRE &&
4334         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4335     {
4336         /* Unassume the success we assumed earlier. */
4337         (void)hv_delete(GvHVn(PL_incgv),
4338                         SvPVX_const(namesv),
4339                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4340                         G_DISCARD);
4341         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4342         NOT_REACHED; /* NOTREACHED */
4343         /* die_unwind() did LEAVE, or we won't be here */
4344     }
4345     else {
4346         LEAVE_with_name("eval");
4347         if (!(save_flags & OPf_SPECIAL)) {
4348             CLEAR_ERRSV();
4349         }
4350     }
4351
4352     RETURNOP(retop);
4353 }
4354
4355 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4356    close to the related Perl_create_eval_scope.  */
4357 void
4358 Perl_delete_eval_scope(pTHX)
4359 {
4360     SV **newsp;
4361     PMOP *newpm;
4362     I32 gimme;
4363     PERL_CONTEXT *cx;
4364     I32 optype;
4365
4366     POPBLOCK(cx,newpm);
4367     POPEVAL(cx);
4368     PL_curpm = newpm;
4369     LEAVE_with_name("eval_scope");
4370     PERL_UNUSED_VAR(newsp);
4371     PERL_UNUSED_VAR(gimme);
4372     PERL_UNUSED_VAR(optype);
4373 }
4374
4375 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4376    also needed by Perl_fold_constants.  */
4377 PERL_CONTEXT *
4378 Perl_create_eval_scope(pTHX_ U32 flags)
4379 {
4380     PERL_CONTEXT *cx;
4381     const I32 gimme = GIMME_V;
4382
4383     ENTER_with_name("eval_scope");
4384     SAVETMPS;
4385
4386     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4387     PUSHEVAL(cx, 0);
4388
4389     PL_in_eval = EVAL_INEVAL;
4390     if (flags & G_KEEPERR)
4391         PL_in_eval |= EVAL_KEEPERR;
4392     else
4393         CLEAR_ERRSV();
4394     if (flags & G_FAKINGEVAL) {
4395         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4396     }
4397     return cx;
4398 }
4399
4400 PP(pp_entertry)
4401 {
4402     dVAR;
4403     PERL_CONTEXT * const cx = create_eval_scope(0);
4404     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4405     return DOCATCH(PL_op->op_next);
4406 }
4407
4408 PP(pp_leavetry)
4409 {
4410     dVAR; dSP;
4411     SV **newsp;
4412     PMOP *newpm;
4413     I32 gimme;
4414     PERL_CONTEXT *cx;
4415     I32 optype;
4416
4417     PERL_ASYNC_CHECK();
4418     POPBLOCK(cx,newpm);
4419     POPEVAL(cx);
4420     PERL_UNUSED_VAR(optype);
4421
4422     TAINT_NOT;
4423     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4424                                SVs_PADTMP|SVs_TEMP, FALSE);
4425     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4426
4427     LEAVE_with_name("eval_scope");
4428     CLEAR_ERRSV();
4429     RETURN;
4430 }
4431
4432 PP(pp_entergiven)
4433 {
4434     dVAR; dSP;
4435     PERL_CONTEXT *cx;
4436     const I32 gimme = GIMME_V;
4437
4438     ENTER_with_name("given");
4439     SAVETMPS;
4440
4441     if (PL_op->op_targ) {
4442         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4443         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4444         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4445     }
4446     else {
4447         SAVE_DEFSV;
4448         DEFSV_set(POPs);
4449     }
4450
4451     PUSHBLOCK(cx, CXt_GIVEN, SP);
4452     PUSHGIVEN(cx);
4453
4454     RETURN;
4455 }