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 #include "feature.h"
  37
  38 #define dopopto_cursub() \
  39     (PL_curstackinfo->si_cxsubix >= 0        \
  40         ? PL_curstackinfo->si_cxsubix        \
  41         : dopoptosub_at(cxstack, cxstack_ix))
  42
  43 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  44
  45 PP(pp_wantarray)
  46 {
  47     dSP;
  48     I32 cxix;
  49     const PERL_CONTEXT *cx;
  50     EXTEND(SP, 1);
  51
  52     if (PL_op->op_private & OPpOFFBYONE) {
  53         if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
  54     }
  55     else {
  56       cxix = dopopto_cursub();
  57       if (cxix < 0)
  58         RETPUSHUNDEF;
  59       cx = &cxstack[cxix];
  60     }
  61
  62     switch (cx->blk_gimme) {
  63     case G_LIST:
  64         RETPUSHYES;
  65     case G_SCALAR:
  66         RETPUSHNO;
  67     default:
  68         RETPUSHUNDEF;
  69     }
  70 }
  71
  72 PP(pp_regcreset)
  73 {
  74     TAINT_NOT;
  75     return NORMAL;
  76 }
  77
  78 PP(pp_regcomp)
  79 {
  80     dSP;
  81     PMOP *pm = cPMOPx(cLOGOP->op_other);
  82     SV **args;
  83     int nargs;
  84     REGEXP *re = NULL;
  85     REGEXP *new_re;
  86     const regexp_engine *eng;
  87     bool is_bare_re= FALSE;
  88
  89     if (PL_op->op_flags & OPf_STACKED) {
  90         dMARK;
  91         nargs = SP - MARK;
  92         args  = ++MARK;
  93     }
  94     else {
  95         nargs = 1;
  96         args  = SP;
  97     }
  98
  99     /* prevent recompiling under /o and ithreads. */
 100 #if defined(USE_ITHREADS)
 101     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
 102         SP = args-1;
 103         RETURN;
 104     }
 105 #endif
 106
 107     re = PM_GETRE(pm);
 108     assert (re != (REGEXP*) &PL_sv_undef);
 109     eng = re ? RX_ENGINE(re) : current_re_engine();
 110
 111     new_re = (eng->op_comp
 112                     ? eng->op_comp
 113                     : &Perl_re_op_compile
 114             )(aTHX_ args, nargs, pm->op_code_list, eng, re,
 115                 &is_bare_re,
 116                 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
 117                 pm->op_pmflags |
 118                     (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
 119
 120     if (pm->op_pmflags & PMf_HAS_CV)
 121         ReANY(new_re)->qr_anoncv
 122                         = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
 123
 124     if (is_bare_re) {
 125         REGEXP *tmp;
 126         /* The match's LHS's get-magic might need to access this op's regexp
 127            (e.g. $' =~ /$re/ while foo; see bug 70764).  So we must call
 128            get-magic now before we replace the regexp. Hopefully this hack can
 129            be replaced with the approach described at
 130            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
 131            some day. */
 132         if (pm->op_type == OP_MATCH) {
 133             SV *lhs;
 134             const bool was_tainted = TAINT_get;
 135             if (pm->op_flags & OPf_STACKED)
 136                 lhs = args[-1];
 137             else if (pm->op_targ)
 138                 lhs = PAD_SV(pm->op_targ);
 139             else lhs = DEFSV;
 140             SvGETMAGIC(lhs);
 141             /* Restore the previous value of PL_tainted (which may have been
 142                modified by get-magic), to avoid incorrectly setting the
 143                RXf_TAINTED flag with RX_TAINT_on further down. */
 144             TAINT_set(was_tainted);
 145 #ifdef NO_TAINT_SUPPORT
 146             PERL_UNUSED_VAR(was_tainted);
 147 #endif
 148         }
 149         tmp = reg_temp_copy(NULL, new_re);
 150         ReREFCNT_dec(new_re);
 151         new_re = tmp;
 152     }
 153
 154     if (re != new_re) {
 155         ReREFCNT_dec(re);
 156         PM_SETRE(pm, new_re);
 157     }
 158
 159
 160     assert(TAINTING_get || !TAINT_get);
 161     if (TAINT_get) {
 162         SvTAINTED_on((SV*)new_re);
 163         RX_TAINT_on(new_re);
 164     }
 165
 166     /* handle the empty pattern */
 167     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
 168         if (PL_curpm == PL_reg_curpm) {
 169             if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
 170                 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
 171             }
 172         }
 173     }
 174
 175 #if !defined(USE_ITHREADS)
 176     /* can't change the optree at runtime either */
 177     /* PMf_KEEP is handled differently under threads to avoid these problems */
 178     if (pm->op_pmflags & PMf_KEEP) {
 179         cLOGOP->op_first->op_next = PL_op->op_next;
 180     }
 181 #endif
 182
 183     SP = args-1;
 184     RETURN;
 185 }
 186
 187
 188 PP(pp_substcont)
 189 {
 190     dSP;
 191     PERL_CONTEXT *cx = CX_CUR();
 192     PMOP * const pm = cPMOPx(cLOGOP->op_other);
 193     SV * const dstr = cx->sb_dstr;
 194     char *s = cx->sb_s;
 195     char *m = cx->sb_m;
 196     char *orig = cx->sb_orig;
 197     REGEXP * const rx = cx->sb_rx;
 198     SV *nsv = NULL;
 199     REGEXP *old = PM_GETRE(pm);
 200
 201     PERL_ASYNC_CHECK();
 202
 203     if(old != rx) {
 204         if(old)
 205             ReREFCNT_dec(old);
 206         PM_SETRE(pm,ReREFCNT_inc(rx));
 207     }
 208
 209     rxres_restore(&cx->sb_rxres, rx);
 210
 211     if (cx->sb_iters++) {
 212         const SSize_t saviters = cx->sb_iters;
 213         if (cx->sb_iters > cx->sb_maxiters)
 214             DIE(aTHX_ "Substitution loop");
 215
 216         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
 217
 218         /* See "how taint works": pp_subst() in pp_hot.c */
 219         sv_catsv_nomg(dstr, POPs);
 220         if (UNLIKELY(TAINT_get))
 221             cx->sb_rxtainted |= SUBST_TAINT_REPL;
 222         if (CxONCE(cx) || s < orig ||
 223                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 224                              (s == m), cx->sb_targ, NULL,
 225                     (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
 226         {
 227             SV *targ = cx->sb_targ;
 228
 229             assert(cx->sb_strend >= s);
 230             if(cx->sb_strend > s) {
 231                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 232                       sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 233                  else
 234                       sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
 235             }
 236             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 237                 cx->sb_rxtainted |= SUBST_TAINT_PAT;
 238
 239             if (pm->op_pmflags & PMf_NONDESTRUCT) {
 240                 PUSHs(dstr);
 241                 /* From here on down we're using the copy, and leaving the
 242                    original untouched.  */
 243                 targ = dstr;
 244             }
 245             else {
 246                 SV_CHECK_THINKFIRST_COW_DROP(targ);
 247                 if (isGV(targ)) Perl_croak_no_modify();
 248                 SvPV_free(targ);
 249                 SvPV_set(targ, SvPVX(dstr));
 250                 SvCUR_set(targ, SvCUR(dstr));
 251                 SvLEN_set(targ, SvLEN(dstr));
 252                 if (DO_UTF8(dstr))
 253                     SvUTF8_on(targ);
 254                 SvPV_set(dstr, NULL);
 255
 256                 PL_tainted = 0;
 257                 mPUSHi(saviters - 1);
 258
 259                 (void)SvPOK_only_UTF8(targ);
 260             }
 261
 262             /* update the taint state of various variables in
 263              * preparation for final exit.
 264              * See "how taint works": pp_subst() in pp_hot.c */
 265             if (TAINTING_get) {
 266                 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 267                     ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 268                                     == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 269                 )
 270                     (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 271
 272                 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
 273                     && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
 274                 )
 275                     SvTAINTED_on(TOPs);  /* taint return value */
 276                 /* needed for mg_set below */
 277                 TAINT_set(
 278                     cBOOL(cx->sb_rxtainted &
 279                           (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
 280                 );
 281
 282                 /* sv_magic(), when adding magic (e.g.taint magic), also
 283                  * recalculates any pos() magic, converting any byte offset
 284                  * to utf8 offset. Make sure pos() is reset before this
 285                  * happens rather than using the now invalid value (since
 286                  * we've just replaced targ's pvx buffer with the
 287                  * potentially shorter dstr buffer). Normally (i.e. in
 288                  * non-taint cases), pos() gets removed a few lines later
 289                  * with the SvSETMAGIC().
 290                  */
 291                 {
 292                     MAGIC *mg;
 293                     mg = mg_find_mglob(targ);
 294                     if (mg) {
 295                         MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
 296                     }
 297                 }
 298
 299                 SvTAINT(TARG);
 300             }
 301             /* PL_tainted must be correctly set for this mg_set */
 302             SvSETMAGIC(TARG);
 303             TAINT_NOT;
 304
 305             CX_LEAVE_SCOPE(cx);
 306             CX_POPSUBST(cx);
 307             CX_POP(cx);
 308
 309             PERL_ASYNC_CHECK();
 310             RETURNOP(pm->op_next);
 311             NOT_REACHED; /* NOTREACHED */
 312         }
 313         cx->sb_iters = saviters;
 314     }
 315     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 316         m = s;
 317         s = orig;
 318         assert(!RX_SUBOFFSET(rx));
 319         cx->sb_orig = orig = RX_SUBBEG(rx);
 320         s = orig + (m - s);
 321         cx->sb_strend = s + (cx->sb_strend - m);
 322     }
 323     cx->sb_m = m = RX_OFFS_START(rx,0) + orig;
 324     if (m > s) {
 325         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 326             sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
 327         else
 328             sv_catpvn_nomg(dstr, s, m-s);
 329     }
 330     cx->sb_s = RX_OFFS_END(rx,0) + orig;
 331     { /* Update the pos() information. */
 332         SV * const sv
 333             = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
 334         MAGIC *mg;
 335
 336         /* the string being matched against may no longer be a string,
 337          * e.g. $_=0; s/.../$_++/ge */
 338
 339         if (!SvPOK(sv))
 340             SvPV_force_nomg_nolen(sv);
 341
 342         if (!(mg = mg_find_mglob(sv))) {
 343             mg = sv_magicext_mglob(sv);
 344         }
 345         MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
 346     }
 347     if (old != rx)
 348         (void)ReREFCNT_inc(rx);
 349     /* update the taint state of various variables in preparation
 350      * for calling the code block.
 351      * See "how taint works": pp_subst() in pp_hot.c */
 352     if (TAINTING_get) {
 353         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 354             cx->sb_rxtainted |= SUBST_TAINT_PAT;
 355
 356         if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 357             ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 358                             == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 359         )
 360             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 361
 362         if (cx->sb_iters > 1 && (cx->sb_rxtainted &
 363                         (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
 364             SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
 365                          ? cx->sb_dstr : cx->sb_targ);
 366         TAINT_NOT;
 367     }
 368     rxres_save(&cx->sb_rxres, rx);
 369     PL_curpm = pm;
 370     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 371 }
 372
 373 void
 374 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 375 {
 376     UV *p = (UV*)*rsp;
 377     U32 i;
 378
 379     PERL_ARGS_ASSERT_RXRES_SAVE;
 380     PERL_UNUSED_CONTEXT;
 381
 382     /* deal with regexp_paren_pair items */
 383     if (!p || p[1] < RX_NPARENS(rx)) {
 384 #ifdef PERL_ANY_COW
 385         i = 7 + (RX_NPARENS(rx)+1) * 2;
 386 #else
 387         i = 6 + (RX_NPARENS(rx)+1) * 2;
 388 #endif
 389         if (!p)
 390             Newx(p, i, UV);
 391         else
 392             Renew(p, i, UV);
 393         *rsp = (void*)p;
 394     }
 395
 396     /* what (if anything) to free on croak */
 397     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 398     RX_MATCH_COPIED_off(rx);
 399     *p++ = RX_NPARENS(rx);
 400
 401 #ifdef PERL_ANY_COW
 402     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 403     RX_SAVED_COPY(rx) = NULL;
 404 #endif
 405
 406     *p++ = PTR2UV(RX_SUBBEG(rx));
 407     *p++ = (UV)RX_SUBLEN(rx);
 408     *p++ = (UV)RX_SUBOFFSET(rx);
 409     *p++ = (UV)RX_SUBCOFFSET(rx);
 410     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 411         *p++ = (UV)RX_OFFSp(rx)[i].start;
 412         *p++ = (UV)RX_OFFSp(rx)[i].end;
 413     }
 414 }
 415
 416 static void
 417 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 418 {
 419     UV *p = (UV*)*rsp;
 420     U32 i;
 421
 422     PERL_ARGS_ASSERT_RXRES_RESTORE;
 423     PERL_UNUSED_CONTEXT;
 424
 425     RX_MATCH_COPY_FREE(rx);
 426     RX_MATCH_COPIED_set(rx, *p);
 427     *p++ = 0;
 428     RX_NPARENS(rx) = *p++;
 429
 430 #ifdef PERL_ANY_COW
 431     if (RX_SAVED_COPY(rx))
 432         SvREFCNT_dec (RX_SAVED_COPY(rx));
 433     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 434     *p++ = 0;
 435 #endif
 436
 437     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 438     RX_SUBLEN(rx) = (I32)(*p++);
 439     RX_SUBOFFSET(rx) = (I32)*p++;
 440     RX_SUBCOFFSET(rx) = (I32)*p++;
 441     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 442         RX_OFFSp(rx)[i].start = (I32)(*p++);
 443         RX_OFFSp(rx)[i].end = (I32)(*p++);
 444     }
 445 }
 446
 447 static void
 448 S_rxres_free(pTHX_ void **rsp)
 449 {
 450     UV * const p = (UV*)*rsp;
 451
 452     PERL_ARGS_ASSERT_RXRES_FREE;
 453     PERL_UNUSED_CONTEXT;
 454
 455     if (p) {
 456         void *tmp = INT2PTR(char*,*p);
 457 #ifdef PERL_POISON
 458 #ifdef PERL_ANY_COW
 459         U32 i = 9 + p[1] * 2;
 460 #else
 461         U32 i = 8 + p[1] * 2;
 462 #endif
 463 #endif
 464
 465 #ifdef PERL_ANY_COW
 466         SvREFCNT_dec (INT2PTR(SV*,p[2]));
 467 #endif
 468 #ifdef PERL_POISON
 469         PoisonFree(p, i, sizeof(UV));
 470 #endif
 471
 472         Safefree(tmp);
 473         Safefree(p);
 474         *rsp = NULL;
 475     }
 476 }
 477
 478 #define FORM_NUM_BLANK (1<<30)
 479 #define FORM_NUM_POINT (1<<29)
 480
 481 PP(pp_formline)
 482 {
 483     dSP; dMARK; dORIGMARK;
 484     SV * const tmpForm = *++MARK;
 485     SV *formsv;             /* contains text of original format */
 486     U32 *fpc;       /* format ops program counter */
 487     char *t;        /* current append position in target string */
 488     const char *f;          /* current position in format string */
 489     I32 arg;
 490     SV *sv = NULL; /* current item */
 491     const char *item = NULL;/* string value of current item */
 492     I32 itemsize  = 0;      /* length (chars) of item, possibly truncated */
 493     I32 itembytes = 0;      /* as itemsize, but length in bytes */
 494     I32 fieldsize = 0;      /* width of current field */
 495     I32 lines = 0;          /* number of lines that have been output */
 496     bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
 497     const char *chophere = NULL; /* where to chop current item */
 498     STRLEN linemark = 0;    /* pos of start of line in output */
 499     NV value;
 500     bool gotsome = FALSE;   /* seen at least one non-blank item on this line */
 501     STRLEN len;             /* length of current sv */
 502     STRLEN linemax;         /* estimate of output size in bytes */
 503     bool item_is_utf8 = FALSE;
 504     bool targ_is_utf8 = FALSE;
 505     const char *fmt;
 506     MAGIC *mg = NULL;
 507     U8 *source;             /* source of bytes to append */
 508     STRLEN to_copy;         /* how may bytes to append */
 509     char trans;             /* what chars to translate */
 510     bool copied_form = FALSE; /* have we duplicated the form? */
 511
 512     mg = doparseform(tmpForm);
 513
 514     fpc = (U32*)mg->mg_ptr;
 515     /* the actual string the format was compiled from.
 516      * with overload etc, this may not match tmpForm */
 517     formsv = mg->mg_obj;
 518
 519
 520     SvPV_force(PL_formtarget, len);
 521     if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
 522         SvTAINTED_on(PL_formtarget);
 523     if (DO_UTF8(PL_formtarget))
 524         targ_is_utf8 = TRUE;
 525     /* this is an initial estimate of how much output buffer space
 526      * to allocate. It may be exceeded later */
 527     linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
 528     t = SvGROW(PL_formtarget, len + linemax + 1);
 529     /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
 530     t += len;
 531     f = SvPV_const(formsv, len);
 532
 533     for (;;) {
 534         DEBUG_f( {
 535             const char *name = "???";
 536             arg = -1;
 537             switch (*fpc) {
 538             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 539             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 540             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 541             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 542             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 543
 544             case FF_CHECKNL:    name = "CHECKNL";       break;
 545             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 546             case FF_SPACE:      name = "SPACE";         break;
 547             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 548             case FF_ITEM:       name = "ITEM";          break;
 549             case FF_CHOP:       name = "CHOP";          break;
 550             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 551             case FF_NEWLINE:    name = "NEWLINE";       break;
 552             case FF_MORE:       name = "MORE";          break;
 553             case FF_LINEMARK:   name = "LINEMARK";      break;
 554             case FF_END:        name = "END";           break;
 555             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 556             case FF_LINESNGL:   name = "LINESNGL";      break;
 557             }
 558             if (arg >= 0)
 559                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 560             else
 561                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 562         } );
 563         switch (*fpc++) {
 564         case FF_LINEMARK: /* start (or end) of a line */
 565             linemark = t - SvPVX(PL_formtarget);
 566             lines++;
 567             gotsome = FALSE;
 568             break;
 569
 570         case FF_LITERAL: /* append <arg> literal chars */
 571             to_copy = *fpc++;
 572             source = (U8 *)f;
 573             f += to_copy;
 574             trans = '~';
 575             item_is_utf8 = (targ_is_utf8)
 576                            ? cBOOL(DO_UTF8(formsv))
 577                            : cBOOL(SvUTF8(formsv));
 578             goto append;
 579
 580         case FF_SKIP: /* skip <arg> chars in format */
 581             f += *fpc++;
 582             break;
 583
 584         case FF_FETCH: /* get next item and set field size to <arg> */
 585             arg = *fpc++;
 586             f += arg;
 587             fieldsize = arg;
 588
 589             if (MARK < SP)
 590                 sv = *++MARK;
 591             else {
 592                 sv = &PL_sv_no;
 593                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 594             }
 595             if (SvTAINTED(sv))
 596                 SvTAINTED_on(PL_formtarget);
 597             break;
 598
 599         case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
 600             {
 601                 const char *s = item = SvPV_const(sv, len);
 602                 const char *send = s + len;
 603
 604                 itemsize = 0;
 605                 item_is_utf8 = DO_UTF8(sv);
 606                 while (s < send) {
 607                     if (!isCNTRL(*s))
 608                         gotsome = TRUE;
 609                     else if (*s == '\n')
 610                         break;
 611
 612                     if (item_is_utf8)
 613                         s += UTF8SKIP(s);
 614                     else
 615                         s++;
 616                     itemsize++;
 617                     if (itemsize == fieldsize)
 618                         break;
 619                 }
 620                 itembytes = s - item;
 621                 chophere = s;
 622                 break;
 623             }
 624
 625         case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
 626             {
 627                 const char *s = item = SvPV_const(sv, len);
 628                 const char *send = s + len;
 629                 I32 size = 0;
 630
 631                 chophere = NULL;
 632                 item_is_utf8 = DO_UTF8(sv);
 633                 while (s < send) {
 634                     /* look for a legal split position */
 635                     if (isSPACE(*s)) {
 636                         if (*s == '\r') {
 637                             chophere = s;
 638                             itemsize = size;
 639                             break;
 640                         }
 641                         if (chopspace) {
 642                             /* provisional split point */
 643                             chophere = s;
 644                             itemsize = size;
 645                         }
 646                         /* we delay testing fieldsize until after we've
 647                          * processed the possible split char directly
 648                          * following the last field char; so if fieldsize=3
 649                          * and item="a b cdef", we consume "a b", not "a".
 650                          * Ditto further down.
 651                          */
 652                         if (size == fieldsize)
 653                             break;
 654                     }
 655                     else {
 656                         if (size == fieldsize)
 657                             break;
 658                         if (strchr(PL_chopset, *s)) {
 659                             /* provisional split point */
 660                             /* for a non-space split char, we include
 661                              * the split char; hence the '+1' */
 662                             chophere = s + 1;
 663                             itemsize = size + 1;
 664                         }
 665                         if (!isCNTRL(*s))
 666                             gotsome = TRUE;
 667                     }
 668
 669                     if (item_is_utf8)
 670                         s += UTF8SKIP(s);
 671                     else
 672                         s++;
 673                     size++;
 674                 }
 675                 if (!chophere || s == send) {
 676                     chophere = s;
 677                     itemsize = size;
 678                 }
 679                 itembytes = chophere - item;
 680
 681                 break;
 682             }
 683
 684         case FF_SPACE: /* append padding space (diff of field, item size) */
 685             arg = fieldsize - itemsize;
 686             if (arg) {
 687                 fieldsize -= arg;
 688                 while (arg-- > 0)
 689                     *t++ = ' ';
 690             }
 691             break;
 692
 693         case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
 694             arg = fieldsize - itemsize;
 695             if (arg) {
 696                 arg /= 2;
 697                 fieldsize -= arg;
 698                 while (arg-- > 0)
 699                     *t++ = ' ';
 700             }
 701             break;
 702
 703         case FF_ITEM: /* append a text item, while blanking ctrl chars */
 704             to_copy = itembytes;
 705             source = (U8 *)item;
 706             trans = 1;
 707             goto append;
 708
 709         case FF_CHOP: /* (for ^*) chop the current item */
 710             if (sv != &PL_sv_no) {
 711                 const char *s = chophere;
 712                 if (!copied_form &&
 713                     ((sv == tmpForm || SvSMAGICAL(sv))
 714                      || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
 715                     /* sv and tmpForm are either the same SV, or magic might allow modification
 716                        of tmpForm when sv is modified, so copy */
 717                     SV *newformsv = sv_mortalcopy(formsv);
 718                     U32 *new_compiled;
 719
 720                     f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
 721                     Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
 722                     memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
 723                     SAVEFREEPV(new_compiled);
 724                     fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
 725                     formsv = newformsv;
 726
 727                     copied_form = TRUE;
 728                 }
 729                 if (chopspace) {
 730                     while (isSPACE(*s))
 731                         s++;
 732                 }
 733                 if (SvPOKp(sv))
 734                     sv_chop(sv,s);
 735                 else
 736                     /* tied, overloaded or similar strangeness.
 737                      * Do it the hard way */
 738                     sv_setpvn(sv, s, len - (s-item));
 739                 SvSETMAGIC(sv);
 740                 break;
 741             }
 742             /* FALLTHROUGH */
 743
 744         case FF_LINESNGL: /* process ^*  */
 745             chopspace = 0;
 746             /* FALLTHROUGH */
 747
 748         case FF_LINEGLOB: /* process @*  */
 749             {
 750                 const bool oneline = fpc[-1] == FF_LINESNGL;
 751                 const char *s = item = SvPV_const(sv, len);
 752                 const char *const send = s + len;
 753
 754                 item_is_utf8 = DO_UTF8(sv);
 755                 chophere = s + len;
 756                 if (!len)
 757                     break;
 758                 trans = 0;
 759                 gotsome = TRUE;
 760                 source = (U8 *) s;
 761                 to_copy = len;
 762                 while (s < send) {
 763                     if (*s++ == '\n') {
 764                         if (oneline) {
 765                             to_copy = s - item - 1;
 766                             chophere = s;
 767                             break;
 768                         } else {
 769                             if (s == send) {
 770                                 to_copy--;
 771                             } else
 772                                 lines++;
 773                         }
 774                     }
 775                 }
 776             }
 777
 778         append:
 779             /* append to_copy bytes from source to PL_formstring.
 780              * item_is_utf8 implies source is utf8.
 781              * if trans, translate certain characters during the copy */
 782             {
 783                 U8 *tmp = NULL;
 784                 STRLEN grow = 0;
 785
 786                 SvCUR_set(PL_formtarget,
 787                           t - SvPVX_const(PL_formtarget));
 788
 789                 if (targ_is_utf8 && !item_is_utf8) {
 790                     source = tmp = bytes_to_utf8(source, &to_copy);
 791                     grow = to_copy;
 792                 } else {
 793                     if (item_is_utf8 && !targ_is_utf8) {
 794                         U8 *s;
 795                         /* Upgrade targ to UTF8, and then we reduce it to
 796                            a problem we have a simple solution for.
 797                            Don't need get magic.  */
 798                         sv_utf8_upgrade_nomg(PL_formtarget);
 799                         targ_is_utf8 = TRUE;
 800                         /* re-calculate linemark */
 801                         s = (U8*)SvPVX(PL_formtarget);
 802                         /* the bytes we initially allocated to append the
 803                          * whole line may have been gobbled up during the
 804                          * upgrade, so allocate a whole new line's worth
 805                          * for safety */
 806                         grow = linemax;
 807                         while (linemark--)
 808                             s += UTF8_SAFE_SKIP(s,
 809                                             (U8 *) SvEND(PL_formtarget));
 810                         linemark = s - (U8*)SvPVX(PL_formtarget);
 811                     }
 812                     /* Easy. They agree.  */
 813                     assert (item_is_utf8 == targ_is_utf8);
 814                 }
 815                 if (!trans)
 816                     /* @* and ^* are the only things that can exceed
 817                      * the linemax, so grow by the output size, plus
 818                      * a whole new form's worth in case of any further
 819                      * output */
 820                     grow = linemax + to_copy;
 821                 if (grow)
 822                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
 823                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 824
 825                 Copy(source, t, to_copy, char);
 826                 if (trans) {
 827                     /* blank out ~ or control chars, depending on trans.
 828                      * works on bytes not chars, so relies on not
 829                      * matching utf8 continuation bytes */
 830                     U8 *s = (U8*)t;
 831                     U8 *send = s + to_copy;
 832                     while (s < send) {
 833                         const int ch = *s;
 834                         if (trans == '~' ? (ch == '~') : isCNTRL(ch))
 835                             *s = ' ';
 836                         s++;
 837                     }
 838                 }
 839
 840                 t += to_copy;
 841                 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 842                 if (tmp)
 843                     Safefree(tmp);
 844                 break;
 845             }
 846
 847         case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
 848             arg = *fpc++;
 849             fmt = (const char *)
 850                 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
 851             goto ff_dec;
 852
 853         case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
 854             arg = *fpc++;
 855             fmt = (const char *)
 856                 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
 857         ff_dec:
 858             /* If the field is marked with ^ and the value is undefined,
 859                blank it out. */
 860             if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
 861                 arg = fieldsize;
 862                 while (arg--)
 863                     *t++ = ' ';
 864                 break;
 865             }
 866             gotsome = TRUE;
 867             value = SvNV(sv);
 868             /* overflow evidence */
 869             if (num_overflow(value, fieldsize, arg)) {
 870                 arg = fieldsize;
 871                 while (arg--)
 872                     *t++ = '#';
 873                 break;
 874             }
 875             /* Formats aren't yet marked for locales, so assume "yes". */
 876             {
 877                 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
 878                 int len;
 879                 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
 880 #ifdef USE_QUADMATH
 881                 {
 882                     int len;
 883                     if (!quadmath_format_valid(fmt))
 884                         Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
 885                     WITH_LC_NUMERIC_SET_TO_NEEDED(
 886                         len = quadmath_snprintf(t, max, fmt, (int) fieldsize,
 887                                                (int) arg, value);
 888                     );
 889                     if (len == -1)
 890                         Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
 891                 }
 892 #else
 893                 /* we generate fmt ourselves so it is safe */
 894                 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
 895                 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
 896                 GCC_DIAG_RESTORE_STMT;
 897 #endif
 898                 PERL_MY_SNPRINTF_POST_GUARD(len, max);
 899             }
 900             t += fieldsize;
 901             break;
 902
 903         case FF_NEWLINE: /* delete trailing spaces, then append \n */
 904             f++;
 905             while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
 906             t++;
 907             *t++ = '\n';
 908             break;
 909
 910         case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
 911             arg = *fpc++;
 912             if (gotsome) {
 913                 if (arg) {              /* repeat until fields exhausted? */
 914                     fpc--;
 915                     goto end;
 916                 }
 917             }
 918             else {
 919                 t = SvPVX(PL_formtarget) + linemark;
 920                 lines--;
 921             }
 922             break;
 923
 924         case FF_MORE: /* replace long end of string with '...' */
 925             {
 926                 const char *s = chophere;
 927                 const char *send = item + len;
 928                 if (chopspace) {
 929                     while (isSPACE(*s) && (s < send))
 930                         s++;
 931                 }
 932                 if (s < send) {
 933                     char *s1;
 934                     arg = fieldsize - itemsize;
 935                     if (arg) {
 936                         fieldsize -= arg;
 937                         while (arg-- > 0)
 938                             *t++ = ' ';
 939                     }
 940                     s1 = t - 3;
 941                     if (strBEGINs(s1,"   ")) {
 942                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 943                             s1--;
 944                     }
 945                     *s1++ = '.';
 946                     *s1++ = '.';
 947                     *s1++ = '.';
 948                 }
 949                 break;
 950             }
 951
 952         case FF_END: /* tidy up, then return */
 953         end:
 954             assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
 955             *t = '\0';
 956             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 957             if (targ_is_utf8)
 958                 SvUTF8_on(PL_formtarget);
 959             FmLINES(PL_formtarget) += lines;
 960             SP = ORIGMARK;
 961             if (fpc[-1] == FF_BLANK)
 962                 RETURNOP(cLISTOP->op_first);
 963             else
 964                 RETPUSHYES;
 965         }
 966     }
 967 }
 968
 969 /* also used for: pp_mapstart() */
 970 PP(pp_grepstart)
 971 {
 972     /* See the code comments at the start of pp_grepwhile() and
 973      * pp_mapwhile() for an explanation of how the stack is used
 974      * during a grep or map.
 975      */
 976
 977     dSP;
 978     SV *src;
 979
 980     if (PL_stack_base + TOPMARK == SP) {
 981         (void)POPMARK;
 982         if (GIMME_V == G_SCALAR)
 983             XPUSHs(&PL_sv_zero);
 984         RETURNOP(PL_op->op_next->op_next);
 985     }
 986     PL_stack_sp = PL_stack_base + TOPMARK + 1;
 987     PUSHMARK(PL_stack_sp);                              /* push dst */
 988     PUSHMARK(PL_stack_sp);                              /* push src */
 989     ENTER_with_name("grep");                                    /* enter outer scope */
 990
 991     SAVETMPS;
 992     SAVE_DEFSV;
 993     ENTER_with_name("grep_item");                                       /* enter inner scope */
 994     SAVEVPTR(PL_curpm);
 995
 996     src = PL_stack_base[TOPMARK];
 997     if (SvPADTMP(src)) {
 998         src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
 999         PL_tmps_floor++;
1000     }
1001     SvTEMP_off(src);
1002     DEFSV_set(src);
1003
1004     PUTBACK;
1005     if (PL_op->op_type == OP_MAPSTART)
1006         PUSHMARK(PL_stack_sp);                  /* push top */
1007     return cLOGOPx(PL_op->op_next)->op_other;
1008 }
1009
1010 /* pp_grepwhile() lives in pp_hot.c */
1011
1012 PP(pp_mapwhile)
1013 {
1014     /* Understanding the stack during a map.
1015      *
1016      * 'map expr, args' is implemented in the form of
1017      *
1018      *     grepstart; // which handles map too
1019      *     do {
1020      *          expr;
1021      *          mapwhile;
1022      *     } while (args);
1023      *
1024      * The stack examples below are in the form of 'perl -Ds' output,
1025      * where any stack element indexed by PL_markstack_ptr[i] has a star
1026      * just to the right of it.  In addition, the corresponding i value
1027      * is displayed under the indexed stack element.
1028      *
1029      * On entry to mapwhile, the stack looks like this:
1030      *
1031      *      =>   *  A1..An  X1  *  X2..Xn  C  *  R1..Rn  *  E1..En
1032      *      [-3]           [-2]          [-1]        [0]
1033      *
1034      * where:
1035      *   A1..An   Accumulated results from all previous iterations of expr
1036      *   X1..Xn   Random garbage
1037      *   C        The current (just processed) arg, still aliased to $_.
1038      *   R1..Rn   The args remaining to be processed.
1039      *   E1..En   the (list) result of the just-executed map expression.
1040      *
1041      * Note that it is easiest to think of stack marks [-1] and [-2] as both
1042      * being one too high, and so it would make more sense to have had the
1043      * marks like this:
1044      *
1045      *      =>   *  A1..An  *  X1..Xn  *  C  R1..Rn  *  E1..En
1046      *      [-3]       [-2]       [-1]           [0]
1047      *
1048      * where the stack is divided neatly into 4 groups:
1049      *   - accumulated results
1050      *   - discards and/or holes proactively created for later result storage
1051      *   - being, or yet to be, processed,
1052      *   - results of last expr
1053      * But off-by-one is the way it is currently, and it works as long as
1054      * we keep it consistent and bear it in mind.
1055      *
1056      * pp_mapwhile() does the following:
1057      *
1058      * - If there isn't enough space in the X1..Xn zone to insert the
1059      *   expression results, grow the stack and shift up everything above C.
1060      * - move E1..En to just above An
1061      * - at the same time, manipulate the tmps stack so that temporaries
1062      *   from executing expr can be freed without prematurely freeing
1063      *   E1..En.
1064      * - if on last iteration, pop all the marks, reset the stack pointer
1065      *   and update the return args based on caller context.
1066      * - else alias $_ to the next arg.
1067      *
1068      */
1069
1070     dSP;
1071     const U8 gimme = GIMME_V;
1072     I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
1073     I32 count;
1074     I32 shift;
1075     SV** src;
1076     SV** dst;
1077
1078     /* first, move source pointer to the next item in the source list */
1079     ++PL_markstack_ptr[-1];
1080
1081     /* if there are new items, push them into the destination list */
1082     if (items && gimme != G_VOID) {
1083         /* might need to make room back there first */
1084         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1085             /* XXX this implementation is very pessimal because the stack
1086              * is repeatedly extended for every set of items.  Is possible
1087              * to do this without any stack extension or copying at all
1088              * by maintaining a separate list over which the map iterates
1089              * (like foreach does). --gsar */
1090
1091             /* everything in the stack after the destination list moves
1092              * towards the end the stack by the amount of room needed */
1093             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1094
1095             /* items to shift up (accounting for the moved source pointer) */
1096             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1097
1098             /* This optimization is by Ben Tilly and it does
1099              * things differently from what Sarathy (gsar)
1100              * is describing.  The downside of this optimization is
1101              * that leaves "holes" (uninitialized and hopefully unused areas)
1102              * to the Perl stack, but on the other hand this
1103              * shouldn't be a problem.  If Sarathy's idea gets
1104              * implemented, this optimization should become
1105              * irrelevant.  --jhi */
1106             if (shift < count)
1107                 shift = count; /* Avoid shifting too often --Ben Tilly */
1108
1109             EXTEND(SP,shift);
1110             src = SP;
1111             dst = (SP += shift);
1112             PL_markstack_ptr[-1] += shift;
1113             *PL_markstack_ptr += shift;
1114             while (count--)
1115                 *dst-- = *src--;
1116         }
1117         /* copy the new items down to the destination list */
1118         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1119         if (gimme == G_LIST) {
1120             /* add returned items to the collection (making mortal copies
1121              * if necessary), then clear the current temps stack frame
1122              * *except* for those items. We do this splicing the items
1123              * into the start of the tmps frame (so some items may be on
1124              * the tmps stack twice), then moving PL_tmps_floor above
1125              * them, then freeing the frame. That way, the only tmps that
1126              * accumulate over iterations are the return values for map.
1127              * We have to do to this way so that everything gets correctly
1128              * freed if we die during the map.
1129              */
1130             I32 tmpsbase;
1131             I32 i = items;
1132             /* make space for the slice */
1133             EXTEND_MORTAL(items);
1134             tmpsbase = PL_tmps_floor + 1;
1135             Move(PL_tmps_stack + tmpsbase,
1136                  PL_tmps_stack + tmpsbase + items,
1137                  PL_tmps_ix - PL_tmps_floor,
1138                  SV*);
1139             PL_tmps_ix += items;
1140
1141             while (i-- > 0) {
1142                 SV *sv = POPs;
1143                 if (!SvTEMP(sv))
1144                     sv = sv_mortalcopy(sv);
1145                 *dst-- = sv;
1146                 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1147             }
1148             /* clear the stack frame except for the items */
1149             PL_tmps_floor += items;
1150             FREETMPS;
1151             /* FREETMPS may have cleared the TEMP flag on some of the items */
1152             i = items;
1153             while (i-- > 0)
1154                 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1155         }
1156         else {
1157             /* scalar context: we don't care about which values map returns
1158              * (we use undef here). And so we certainly don't want to do mortal
1159              * copies of meaningless values. */
1160             while (items-- > 0) {
1161                 (void)POPs;
1162                 *dst-- = &PL_sv_undef;
1163             }
1164             FREETMPS;
1165         }
1166     }
1167     else {
1168         FREETMPS;
1169     }
1170     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1171
1172     /* All done yet? */
1173     if (PL_markstack_ptr[-1] > TOPMARK) {
1174
1175         (void)POPMARK;                          /* pop top */
1176         LEAVE_with_name("grep");                                        /* exit outer scope */
1177         (void)POPMARK;                          /* pop src */
1178         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1179         (void)POPMARK;                          /* pop dst */
1180         SP = PL_stack_base + POPMARK;           /* pop original mark */
1181         if (gimme == G_SCALAR) {
1182                 dTARGET;
1183                 XPUSHi(items);
1184         }
1185         else if (gimme == G_LIST)
1186             SP += items;
1187         RETURN;
1188     }
1189     else {
1190         SV *src;
1191
1192         ENTER_with_name("grep_item");                                   /* enter inner scope */
1193         SAVEVPTR(PL_curpm);
1194
1195         /* set $_ to the new source item */
1196         src = PL_stack_base[PL_markstack_ptr[-1]];
1197         if (SvPADTMP(src)) {
1198             src = sv_mortalcopy(src);
1199         }
1200         SvTEMP_off(src);
1201         DEFSV_set(src);
1202
1203         RETURNOP(cLOGOP->op_other);
1204     }
1205 }
1206
1207 /* Range stuff. */
1208
1209 PP(pp_range)
1210 {
1211     dTARG;
1212     if (GIMME_V == G_LIST)
1213         return NORMAL;
1214     GETTARGET;
1215     if (SvTRUE_NN(targ))
1216         return cLOGOP->op_other;
1217     else
1218         return NORMAL;
1219 }
1220
1221 PP(pp_flip)
1222 {
1223     dSP;
1224
1225     if (GIMME_V == G_LIST) {
1226         RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1227     }
1228     else {
1229         dTOPss;
1230         SV * const targ = PAD_SV(PL_op->op_targ);
1231         int flip = 0;
1232
1233         if (PL_op->op_private & OPpFLIP_LINENUM) {
1234             if (GvIO(PL_last_in_gv)) {
1235                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1236             }
1237             else {
1238                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1239                 if (gv && GvSV(gv))
1240                     flip = SvIV(sv) == SvIV(GvSV(gv));
1241             }
1242         } else {
1243             flip = SvTRUE_NN(sv);
1244         }
1245         if (flip) {
1246             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1247             if (PL_op->op_flags & OPf_SPECIAL) {
1248                 sv_setiv(targ, 1);
1249                 SETs(targ);
1250                 RETURN;
1251             }
1252             else {
1253                 sv_setiv(targ, 0);
1254                 SP--;
1255                 RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1256             }
1257         }
1258         SvPVCLEAR(TARG);
1259         SETs(targ);
1260         RETURN;
1261     }
1262 }
1263
1264 /* This code tries to decide if "$left .. $right" should use the
1265    magical string increment, or if the range is numeric. Initially,
1266    an exception was made for *any* string beginning with "0" (see
1267    [#18165], AMS 20021031), but now that is only applied when the
1268    string's length is also >1 - see the rules now documented in
1269    perlop [#133695] */
1270
1271 #define RANGE_IS_NUMERIC(left,right) ( \
1272         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1273         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1274         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1275           looks_like_number(left)) && SvPOKp(left) \
1276           && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1277          && (!SvOK(right) || looks_like_number(right))))
1278
1279 PP(pp_flop)
1280 {
1281     dSP;
1282
1283     if (GIMME_V == G_LIST) {
1284         dPOPPOPssrl;
1285
1286         SvGETMAGIC(left);
1287         SvGETMAGIC(right);
1288
1289         if (RANGE_IS_NUMERIC(left,right)) {
1290             IV i, j, n;
1291             if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1292                 (SvOK(right) && (SvIOK(right)
1293                                  ? SvIsUV(right) && SvUV(right) > IV_MAX
1294                                  : SvNV_nomg(right) > (NV) IV_MAX)))
1295                 DIE(aTHX_ "Range iterator outside integer range");
1296             i = SvIV_nomg(left);
1297             j = SvIV_nomg(right);
1298             if (j >= i) {
1299                 /* Dance carefully around signed max. */
1300                 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1301                 if (!overflow) {
1302                     n = j - i + 1;
1303                     /* The wraparound of signed integers is undefined
1304                      * behavior, but here we aim for count >=1, and
1305                      * negative count is just wrong. */
1306                     if (n < 1
1307 #if IVSIZE > Size_t_size
1308                         || n > SSize_t_MAX
1309 #endif
1310                         )
1311                         overflow = TRUE;
1312                 }
1313                 if (overflow)
1314                     Perl_croak(aTHX_ "Out of memory during list extend");
1315                 EXTEND_MORTAL(n);
1316                 EXTEND(SP, n);
1317             }
1318             else
1319                 n = 0;
1320             while (n--) {
1321                 SV * const sv = sv_2mortal(newSViv(i));
1322                 PUSHs(sv);
1323                 if (n) /* avoid incrementing above IV_MAX */
1324                     i++;
1325             }
1326         }
1327         else {
1328             STRLEN len, llen;
1329             const char * const lpv = SvPV_nomg_const(left, llen);
1330             const char * const tmps = SvPV_nomg_const(right, len);
1331
1332             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1333             if (DO_UTF8(right) && IN_UNI_8_BIT)
1334                 len = sv_len_utf8_nomg(right);
1335             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1336                 XPUSHs(sv);
1337                 if (strEQ(SvPVX_const(sv),tmps))
1338                     break;
1339                 sv = sv_2mortal(newSVsv(sv));
1340                 sv_inc(sv);
1341             }
1342         }
1343     }
1344     else {
1345         dTOPss;
1346         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1347         int flop = 0;
1348         sv_inc(targ);
1349
1350         if (PL_op->op_private & OPpFLIP_LINENUM) {
1351             if (GvIO(PL_last_in_gv)) {
1352                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1353             }
1354             else {
1355                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1356                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1357             }
1358         }
1359         else {
1360             flop = SvTRUE_NN(sv);
1361         }
1362
1363         if (flop) {
1364             sv_setiv(PAD_SV(cUNOPx(cUNOP->op_first)->op_first->op_targ), 0);
1365             sv_catpvs(targ, "E0");
1366         }
1367         SETs(targ);
1368     }
1369
1370     RETURN;
1371 }
1372
1373 /* Control. */
1374
1375 static const char * const context_name[] = {
1376     "pseudo-block",
1377     NULL, /* CXt_WHEN never actually needs "block" */
1378     NULL, /* CXt_BLOCK never actually needs "block" */
1379     NULL, /* CXt_GIVEN never actually needs "block" */
1380     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1381     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1382     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1383     NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1384     NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1385     "subroutine",
1386     "format",
1387     "eval",
1388     "substitution",
1389     "defer block",
1390 };
1391
1392 STATIC I32
1393 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1394 {
1395     I32 i;
1396
1397     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1398
1399     for (i = cxstack_ix; i >= 0; i--) {
1400         const PERL_CONTEXT * const cx = &cxstack[i];
1401         switch (CxTYPE(cx)) {
1402         case CXt_EVAL:
1403             if(CxTRY(cx))
1404                 continue;
1405             /* FALLTHROUGH */
1406         case CXt_SUBST:
1407         case CXt_SUB:
1408         case CXt_FORMAT:
1409         case CXt_NULL:
1410             /* diag_listed_as: Exiting subroutine via %s */
1411             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1412                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1413             if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1414                 return -1;
1415             break;
1416         case CXt_LOOP_PLAIN:
1417         case CXt_LOOP_LAZYIV:
1418         case CXt_LOOP_LAZYSV:
1419         case CXt_LOOP_LIST:
1420         case CXt_LOOP_ARY:
1421           {
1422             STRLEN cx_label_len = 0;
1423             U32 cx_label_flags = 0;
1424             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1425             if (!cx_label || !(
1426                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1427                         (flags & SVf_UTF8)
1428                             ? (bytes_cmp_utf8(
1429                                         (const U8*)cx_label, cx_label_len,
1430                                         (const U8*)label, len) == 0)
1431                             : (bytes_cmp_utf8(
1432                                         (const U8*)label, len,
1433                                         (const U8*)cx_label, cx_label_len) == 0)
1434                     : (len == cx_label_len && ((cx_label == label)
1435                                     || memEQ(cx_label, label, len))) )) {
1436                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1437                         (long)i, cx_label));
1438                 continue;
1439             }
1440             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1441             return i;
1442           }
1443         }
1444     }
1445     return i;
1446 }
1447
1448 /*
1449 =for apidoc_section $callback
1450 =for apidoc dowantarray
1451
1452 Implements the deprecated L<perlapi/C<GIMME>>.
1453
1454 =cut
1455 */
1456
1457 U8
1458 Perl_dowantarray(pTHX)
1459 {
1460     const U8 gimme = block_gimme();
1461     return (gimme == G_VOID) ? G_SCALAR : gimme;
1462 }
1463
1464 /* note that this function has mostly been superseded by Perl_gimme_V */
1465
1466 U8
1467 Perl_block_gimme(pTHX)
1468 {
1469     const I32 cxix = dopopto_cursub();
1470     U8 gimme;
1471     if (cxix < 0)
1472         return G_VOID;
1473
1474     gimme = (cxstack[cxix].blk_gimme & G_WANT);
1475     if (!gimme)
1476         Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1477     return gimme;
1478 }
1479
1480 /*
1481 =for apidoc is_lvalue_sub
1482
1483 Returns non-zero if the sub calling this function is being called in an lvalue
1484 context.  Returns 0 otherwise.
1485
1486 =cut
1487 */
1488
1489 I32
1490 Perl_is_lvalue_sub(pTHX)
1491 {
1492     const I32 cxix = dopopto_cursub();
1493     assert(cxix >= 0);  /* We should only be called from inside subs */
1494
1495     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1496         return CxLVAL(cxstack + cxix);
1497     else
1498         return 0;
1499 }
1500
1501 /* only used by cx_pushsub() */
1502 I32
1503 Perl_was_lvalue_sub(pTHX)
1504 {
1505     const I32 cxix = dopoptosub(cxstack_ix-1);
1506     assert(cxix >= 0);  /* We should only be called from inside subs */
1507
1508     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1509         return CxLVAL(cxstack + cxix);
1510     else
1511         return 0;
1512 }
1513
1514 STATIC I32
1515 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1516 {
1517     I32 i;
1518
1519     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1520 #ifndef DEBUGGING
1521     PERL_UNUSED_CONTEXT;
1522 #endif
1523
1524     for (i = startingblock; i >= 0; i--) {
1525         const PERL_CONTEXT * const cx = &cxstk[i];
1526         switch (CxTYPE(cx)) {
1527         default:
1528             continue;
1529         case CXt_SUB:
1530             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1531              * twice; the first for the normal foo() call, and the second
1532              * for a faked up re-entry into the sub to execute the
1533              * code block. Hide this faked entry from the world. */
1534             if (cx->cx_type & CXp_SUB_RE_FAKE)
1535                 continue;
1536             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1537             return i;
1538
1539         case CXt_EVAL:
1540             if (CxTRY(cx))
1541                 continue;
1542             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1543             return i;
1544
1545         case CXt_FORMAT:
1546             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1547             return i;
1548         }
1549     }
1550     return i;
1551 }
1552
1553 STATIC I32
1554 S_dopoptoeval(pTHX_ I32 startingblock)
1555 {
1556     I32 i;
1557     for (i = startingblock; i >= 0; i--) {
1558         const PERL_CONTEXT *cx = &cxstack[i];
1559         switch (CxTYPE(cx)) {
1560         default:
1561             continue;
1562         case CXt_EVAL:
1563             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1564             return i;
1565         }
1566     }
1567     return i;
1568 }
1569
1570 STATIC I32
1571 S_dopoptoloop(pTHX_ I32 startingblock)
1572 {
1573     I32 i;
1574     for (i = startingblock; i >= 0; i--) {
1575         const PERL_CONTEXT * const cx = &cxstack[i];
1576         switch (CxTYPE(cx)) {
1577         case CXt_EVAL:
1578             if(CxTRY(cx))
1579                 continue;
1580             /* FALLTHROUGH */
1581         case CXt_SUBST:
1582         case CXt_SUB:
1583         case CXt_FORMAT:
1584         case CXt_NULL:
1585             /* diag_listed_as: Exiting subroutine via %s */
1586             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1587                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1588             if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1589                 return -1;
1590             break;
1591         case CXt_LOOP_PLAIN:
1592         case CXt_LOOP_LAZYIV:
1593         case CXt_LOOP_LAZYSV:
1594         case CXt_LOOP_LIST:
1595         case CXt_LOOP_ARY:
1596             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1597             return i;
1598         }
1599     }
1600     return i;
1601 }
1602
1603 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1604
1605 STATIC I32
1606 S_dopoptogivenfor(pTHX_ I32 startingblock)
1607 {
1608     I32 i;
1609     for (i = startingblock; i >= 0; i--) {
1610         const PERL_CONTEXT *cx = &cxstack[i];
1611         switch (CxTYPE(cx)) {
1612         default:
1613             continue;
1614         case CXt_GIVEN:
1615             DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1616             return i;
1617         case CXt_LOOP_PLAIN:
1618             assert(!(cx->cx_type & CXp_FOR_DEF));
1619             break;
1620         case CXt_LOOP_LAZYIV:
1621         case CXt_LOOP_LAZYSV:
1622         case CXt_LOOP_LIST:
1623         case CXt_LOOP_ARY:
1624             if (cx->cx_type & CXp_FOR_DEF) {
1625                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1626                 return i;
1627             }
1628         }
1629     }
1630     return i;
1631 }
1632
1633 STATIC I32
1634 S_dopoptowhen(pTHX_ I32 startingblock)
1635 {
1636     I32 i;
1637     for (i = startingblock; i >= 0; i--) {
1638         const PERL_CONTEXT *cx = &cxstack[i];
1639         switch (CxTYPE(cx)) {
1640         default:
1641             continue;
1642         case CXt_WHEN:
1643             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1644             return i;
1645         }
1646     }
1647     return i;
1648 }
1649
1650 /* dounwind(): pop all contexts above (but not including) cxix.
1651  * Note that it clears the savestack frame associated with each popped
1652  * context entry, but doesn't free any temps.
1653  * It does a cx_popblock() of the last frame that it pops, and leaves
1654  * cxstack_ix equal to cxix.
1655  */
1656
1657 void
1658 Perl_dounwind(pTHX_ I32 cxix)
1659 {
1660     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1661         return;
1662
1663     while (cxstack_ix > cxix) {
1664         PERL_CONTEXT *cx = CX_CUR();
1665
1666         CX_DEBUG(cx, "UNWIND");
1667         /* Note: we don't need to restore the base context info till the end. */
1668
1669         CX_LEAVE_SCOPE(cx);
1670
1671         switch (CxTYPE(cx)) {
1672         case CXt_SUBST:
1673             CX_POPSUBST(cx);
1674             /* CXt_SUBST is not a block context type, so skip the
1675              * cx_popblock(cx) below */
1676             if (cxstack_ix == cxix + 1) {
1677                 cxstack_ix--;
1678                 return;
1679             }
1680             break;
1681         case CXt_SUB:
1682             cx_popsub(cx);
1683             break;
1684         case CXt_EVAL:
1685             cx_popeval(cx);
1686             break;
1687         case CXt_LOOP_PLAIN:
1688         case CXt_LOOP_LAZYIV:
1689         case CXt_LOOP_LAZYSV:
1690         case CXt_LOOP_LIST:
1691         case CXt_LOOP_ARY:
1692             cx_poploop(cx);
1693             break;
1694         case CXt_WHEN:
1695             cx_popwhen(cx);
1696             break;
1697         case CXt_GIVEN:
1698             cx_popgiven(cx);
1699             break;
1700         case CXt_BLOCK:
1701         case CXt_NULL:
1702         case CXt_DEFER:
1703             /* these two don't have a POPFOO() */
1704             break;
1705         case CXt_FORMAT:
1706             cx_popformat(cx);
1707             break;
1708         }
1709         if (cxstack_ix == cxix + 1) {
1710             cx_popblock(cx);
1711         }
1712         cxstack_ix--;
1713     }
1714
1715 }
1716
1717 void
1718 Perl_qerror(pTHX_ SV *err)
1719 {
1720     PERL_ARGS_ASSERT_QERROR;
1721     if (err!=NULL) {
1722         if (PL_in_eval) {
1723             if (PL_in_eval & EVAL_KEEPERR) {
1724                     Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1725                                                         SVfARG(err));
1726             }
1727             else {
1728                 sv_catsv(ERRSV, err);
1729             }
1730         }
1731         else if (PL_errors)
1732             sv_catsv(PL_errors, err);
1733         else
1734             Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1735
1736         if (PL_parser) {
1737             ++PL_parser->error_count;
1738         }
1739     }
1740
1741     if ( PL_parser && (err == NULL ||
1742          PL_parser->error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS)
1743     ) {
1744         const char * const name = OutCopFILE(PL_curcop);
1745         SV * errsv = NULL;
1746         U8 raw_error_count = PERL_PARSE_ERROR_COUNT(PL_parser->error_count);
1747
1748         if (PL_in_eval) {
1749             errsv = ERRSV;
1750         }
1751
1752         if (err == NULL) {
1753             abort_execution(errsv, name);
1754         }
1755         else
1756         if (raw_error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS) {
1757             if (errsv) {
1758                 Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n",
1759                     SVfARG(errsv), name);
1760             } else {
1761                 Perl_croak(aTHX_ "%s has too many errors.\n", name);
1762             }
1763         }
1764     }
1765 }
1766
1767
1768 /* pop a CXt_EVAL context and in addition, if it was a require then
1769  * based on action:
1770  *     0: do nothing extra;
1771  *     1: undef  $INC{$name}; croak "$name did not return a true value";
1772  *     2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1773  */
1774
1775 static void
1776 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1777 {
1778     SV  *namesv = NULL; /* init to avoid dumb compiler warning */
1779     bool do_croak;
1780
1781     CX_LEAVE_SCOPE(cx);
1782     do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1783     if (do_croak) {
1784         /* keep namesv alive after cx_popeval() */
1785         namesv = cx->blk_eval.old_namesv;
1786         cx->blk_eval.old_namesv = NULL;
1787         sv_2mortal(namesv);
1788     }
1789     cx_popeval(cx);
1790     cx_popblock(cx);
1791     CX_POP(cx);
1792
1793     if (do_croak) {
1794         const char *fmt;
1795         HV *inc_hv = GvHVn(PL_incgv);
1796
1797         if (action == 1) {
1798             (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0);
1799             fmt = "%" SVf " did not return a true value";
1800             errsv = namesv;
1801         }
1802         else {
1803             (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0);
1804             fmt = "%" SVf "Compilation failed in require";
1805             if (!errsv)
1806                 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1807         }
1808
1809         Perl_croak(aTHX_ fmt, SVfARG(errsv));
1810     }
1811 }
1812
1813
1814 /* die_unwind(): this is the final destination for the various croak()
1815  * functions. If we're in an eval, unwind the context and other stacks
1816  * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1817  * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1818  * to is a require the exception will be rethrown, as requires don't
1819  * actually trap exceptions.
1820  */
1821
1822 void
1823 Perl_die_unwind(pTHX_ SV *msv)
1824 {
1825     SV *exceptsv = msv;
1826     U8 in_eval = PL_in_eval;
1827     PERL_ARGS_ASSERT_DIE_UNWIND;
1828
1829     if (in_eval) {
1830         I32 cxix;
1831
1832         /* We need to keep this SV alive through all the stack unwinding
1833          * and FREETMPSing below, while ensuing that it doesn't leak
1834          * if we call out to something which then dies (e.g. sub STORE{die}
1835          * when unlocalising a tied var). So we do a dance with
1836          * mortalising and SAVEFREEing.
1837          */
1838         if (PL_phase == PERL_PHASE_DESTRUCT) {
1839             exceptsv = sv_mortalcopy(exceptsv);
1840         } else {
1841             exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1842         }
1843
1844         /*
1845          * Historically, perl used to set ERRSV ($@) early in the die
1846          * process and rely on it not getting clobbered during unwinding.
1847          * That sucked, because it was liable to get clobbered, so the
1848          * setting of ERRSV used to emit the exception from eval{} has
1849          * been moved to much later, after unwinding (see just before
1850          * JMPENV_JUMP below).  However, some modules were relying on the
1851          * early setting, by examining $@ during unwinding to use it as
1852          * a flag indicating whether the current unwinding was caused by
1853          * an exception.  It was never a reliable flag for that purpose,
1854          * being totally open to false positives even without actual
1855          * clobberage, but was useful enough for production code to
1856          * semantically rely on it.
1857          *
1858          * We'd like to have a proper introspective interface that
1859          * explicitly describes the reason for whatever unwinding
1860          * operations are currently in progress, so that those modules
1861          * work reliably and $@ isn't further overloaded.  But we don't
1862          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1863          * now *additionally* set here, before unwinding, to serve as the
1864          * (unreliable) flag that it used to.
1865          *
1866          * This behaviour is temporary, and should be removed when a
1867          * proper way to detect exceptional unwinding has been developed.
1868          * As of 2010-12, the authors of modules relying on the hack
1869          * are aware of the issue, because the modules failed on
1870          * perls 5.13.{1..7} which had late setting of $@ without this
1871          * early-setting hack.
1872          */
1873         if (!(in_eval & EVAL_KEEPERR)) {
1874             /* remove any read-only/magic from the SV, so we don't
1875                get infinite recursion when setting ERRSV */
1876             SANE_ERRSV();
1877             sv_setsv_flags(ERRSV, exceptsv,
1878                         (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1879         }
1880
1881         if (in_eval & EVAL_KEEPERR) {
1882             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1883                            SVfARG(exceptsv));
1884         }
1885
1886         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1887                && PL_curstackinfo->si_prev)
1888         {
1889             dounwind(-1);
1890             POPSTACK;
1891         }
1892
1893         if (cxix >= 0) {
1894             PERL_CONTEXT *cx;
1895             SV **oldsp;
1896             U8 gimme;
1897             JMPENV *restartjmpenv;
1898             OP *restartop;
1899
1900             if (cxix < cxstack_ix)
1901                 dounwind(cxix);
1902
1903             cx = CX_CUR();
1904             assert(CxTYPE(cx) == CXt_EVAL);
1905
1906             /* return false to the caller of eval */
1907             oldsp = PL_stack_base + cx->blk_oldsp;
1908             gimme = cx->blk_gimme;
1909             if (gimme == G_SCALAR)
1910                 *++oldsp = &PL_sv_undef;
1911             PL_stack_sp = oldsp;
1912
1913             restartjmpenv = cx->blk_eval.cur_top_env;
1914             restartop     = cx->blk_eval.retop;
1915
1916             /* We need a FREETMPS here to avoid late-called destructors
1917              * clobbering $@ *after* we set it below, e.g.
1918              *    sub DESTROY { eval { die "X" } }
1919              *    eval { my $x = bless []; die $x = 0, "Y" };
1920              *    is($@, "Y")
1921              * Here the clearing of the $x ref mortalises the anon array,
1922              * which needs to be freed *before* $& is set to "Y",
1923              * otherwise it gets overwritten with "X".
1924              *
1925              * However, the FREETMPS will clobber exceptsv, so preserve it
1926              * on the savestack for now.
1927              */
1928             SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1929             FREETMPS;
1930             /* now we're about to pop the savestack, so re-mortalise it */
1931             sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1932
1933             /* Note that unlike pp_entereval, pp_require isn't supposed to
1934              * trap errors. So if we're a require, after we pop the
1935              * CXt_EVAL that pp_require pushed, rethrow the error with
1936              * croak(exceptsv). This is all handled by the call below when
1937              * action == 2.
1938              */
1939             S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1940
1941             if (!(in_eval & EVAL_KEEPERR)) {
1942                 SANE_ERRSV();
1943                 sv_setsv(ERRSV, exceptsv);
1944             }
1945             PL_restartjmpenv = restartjmpenv;
1946             PL_restartop = restartop;
1947             JMPENV_JUMP(3);
1948             NOT_REACHED; /* NOTREACHED */
1949         }
1950     }
1951
1952     write_to_stderr(exceptsv);
1953     my_failure_exit();
1954     NOT_REACHED; /* NOTREACHED */
1955 }
1956
1957 PP(pp_xor)
1958 {
1959     dSP; dPOPTOPssrl;
1960     if (SvTRUE_NN(left) != SvTRUE_NN(right))
1961         RETSETYES;
1962     else
1963         RETSETNO;
1964 }
1965
1966 /*
1967
1968 =for apidoc_section $CV
1969
1970 =for apidoc caller_cx
1971
1972 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1973 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1974 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1975 stack frame, so C<caller_cx(0, NULL)> will return information for the
1976 immediately-surrounding Perl code.
1977
1978 This function skips over the automatic calls to C<&DB::sub> made on the
1979 behalf of the debugger.  If the stack frame requested was a sub called by
1980 C<DB::sub>, the return value will be the frame for the call to
1981 C<DB::sub>, since that has the correct line number/etc. for the call
1982 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1983 frame for the sub call itself.
1984
1985 =cut
1986 */
1987
1988 const PERL_CONTEXT *
1989 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1990 {
1991     I32 cxix = dopopto_cursub();
1992     const PERL_CONTEXT *cx;
1993     const PERL_CONTEXT *ccstack = cxstack;
1994     const PERL_SI *top_si = PL_curstackinfo;
1995
1996     for (;;) {
1997         /* we may be in a higher stacklevel, so dig down deeper */
1998         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1999             top_si = top_si->si_prev;
2000             ccstack = top_si->si_cxstack;
2001             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
2002         }
2003         if (cxix < 0)
2004             return NULL;
2005         /* caller() should not report the automatic calls to &DB::sub */
2006         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
2007                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
2008             count++;
2009         if (!count--)
2010             break;
2011         cxix = dopoptosub_at(ccstack, cxix - 1);
2012     }
2013
2014     cx = &ccstack[cxix];
2015     if (dbcxp) *dbcxp = cx;
2016
2017     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2018         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2019         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
2020            field below is defined for any cx. */
2021         /* caller() should not report the automatic calls to &DB::sub */
2022         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2023             cx = &ccstack[dbcxix];
2024     }
2025
2026     return cx;
2027 }
2028
2029 PP(pp_caller)
2030 {
2031     dSP;
2032     const PERL_CONTEXT *cx;
2033     const PERL_CONTEXT *dbcx;
2034     U8 gimme = GIMME_V;
2035     const HEK *stash_hek;
2036     I32 count = 0;
2037     bool has_arg = MAXARG && TOPs;
2038     const COP *lcop;
2039
2040     if (MAXARG) {
2041       if (has_arg)
2042         count = POPi;
2043       else (void)POPs;
2044     }
2045
2046     cx = caller_cx(count + cBOOL(PL_op->op_private & OPpOFFBYONE), &dbcx);
2047     if (!cx) {
2048         if (gimme != G_LIST) {
2049             EXTEND(SP, 1);
2050             RETPUSHUNDEF;
2051         }
2052         RETURN;
2053     }
2054
2055     CX_DEBUG(cx, "CALLER");
2056     assert(CopSTASH(cx->blk_oldcop));
2057     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
2058       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
2059       : NULL;
2060     if (gimme != G_LIST) {
2061         EXTEND(SP, 1);
2062         if (!stash_hek)
2063             PUSHs(&PL_sv_undef);
2064         else {
2065             dTARGET;
2066             sv_sethek(TARG, stash_hek);
2067             PUSHs(TARG);
2068         }
2069         RETURN;
2070     }
2071
2072     EXTEND(SP, 11);
2073
2074     if (!stash_hek)
2075         PUSHs(&PL_sv_undef);
2076     else {
2077         dTARGET;
2078         sv_sethek(TARG, stash_hek);
2079         PUSHTARG;
2080     }
2081     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
2082     lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
2083                        cx->blk_sub.retop, TRUE);
2084     if (!lcop)
2085         lcop = cx->blk_oldcop;
2086     mPUSHu(CopLINE(lcop));
2087     if (!has_arg)
2088         RETURN;
2089     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2090         /* So is ccstack[dbcxix]. */
2091         if (CvHASGV(dbcx->blk_sub.cv)) {
2092             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
2093             PUSHs(boolSV(CxHASARGS(cx)));
2094         }
2095         else {
2096             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
2097             PUSHs(boolSV(CxHASARGS(cx)));
2098         }
2099     }
2100     else {
2101         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
2102         PUSHs(&PL_sv_zero);
2103     }
2104     gimme = cx->blk_gimme;
2105     if (gimme == G_VOID)
2106         PUSHs(&PL_sv_undef);
2107     else
2108         PUSHs(boolSV((gimme & G_WANT) == G_LIST));
2109     if (CxTYPE(cx) == CXt_EVAL) {
2110         /* eval STRING */
2111         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
2112             SV *cur_text = cx->blk_eval.cur_text;
2113             if (SvCUR(cur_text) >= 2) {
2114                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
2115                                      SvUTF8(cur_text)|SVs_TEMP));
2116             }
2117             else {
2118                 /* I think this is will always be "", but be sure */
2119                 PUSHs(sv_2mortal(newSVsv(cur_text)));
2120             }
2121
2122             PUSHs(&PL_sv_no);
2123         }
2124         /* require */
2125         else if (cx->blk_eval.old_namesv) {
2126             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2127             PUSHs(&PL_sv_yes);
2128         }
2129         /* eval BLOCK (try blocks have old_namesv == 0) */
2130         else {
2131             PUSHs(&PL_sv_undef);
2132             PUSHs(&PL_sv_undef);
2133         }
2134     }
2135     else {
2136         PUSHs(&PL_sv_undef);
2137         PUSHs(&PL_sv_undef);
2138     }
2139     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2140         && CopSTASH_eq(PL_curcop, PL_debstash))
2141     {
2142         /* slot 0 of the pad contains the original @_ */
2143         AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2144                             PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2145                                 cx->blk_sub.olddepth+1]))[0]);
2146         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2147
2148         Perl_init_dbargs(aTHX);
2149
2150         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2151             av_extend(PL_dbargs, AvFILLp(ary) + off);
2152         if (AvFILLp(ary) + 1 + off)
2153             Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
2154         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2155     }
2156     mPUSHi(CopHINTS_get(cx->blk_oldcop));
2157     {
2158         SV * mask ;
2159         char *old_warnings = cx->blk_oldcop->cop_warnings;
2160
2161         if  (old_warnings == pWARN_NONE)
2162             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2163         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2164             mask = &PL_sv_undef ;
2165         else if (old_warnings == pWARN_ALL ||
2166                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2167             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2168         }
2169         else
2170             mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings));
2171         mPUSHs(mask);
2172     }
2173
2174     PUSHs(cx->blk_oldcop->cop_hints_hash ?
2175           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2176           : &PL_sv_undef);
2177     RETURN;
2178 }
2179
2180 PP(pp_reset)
2181 {
2182     dSP;
2183     const char * tmps;
2184     STRLEN len = 0;
2185     if (MAXARG < 1 || (!TOPs && !POPs)) {
2186         EXTEND(SP, 1);
2187         tmps = NULL, len = 0;
2188     }
2189     else
2190         tmps = SvPVx_const(POPs, len);
2191     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2192     PUSHs(&PL_sv_yes);
2193     RETURN;
2194 }
2195
2196 /* like pp_nextstate, but used instead when the debugger is active */
2197
2198 PP(pp_dbstate)
2199 {
2200     PL_curcop = (COP*)PL_op;
2201     TAINT_NOT;          /* Each statement is presumed innocent */
2202     PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2203     FREETMPS;
2204
2205     PERL_ASYNC_CHECK();
2206
2207     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2208             || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2209     {
2210         dSP;
2211         PERL_CONTEXT *cx;
2212         const U8 gimme = G_LIST;
2213         GV * const gv = PL_DBgv;
2214         CV * cv = NULL;
2215
2216         if (gv && isGV_with_GP(gv))
2217             cv = GvCV(gv);
2218
2219         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2220             DIE(aTHX_ "No DB::DB routine defined");
2221
2222         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2223             /* don't do recursive DB::DB call */
2224             return NORMAL;
2225
2226         if (CvISXSUB(cv)) {
2227             ENTER;
2228             SAVEI32(PL_debug);
2229             PL_debug = 0;
2230             SAVESTACK_POS();
2231             SAVETMPS;
2232             PUSHMARK(SP);
2233             (void)(*CvXSUB(cv))(aTHX_ cv);
2234             FREETMPS;
2235             LEAVE;
2236             return NORMAL;
2237         }
2238         else {
2239             cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2240             cx_pushsub(cx, cv, PL_op->op_next, 0);
2241             /* OP_DBSTATE's op_private holds hint bits rather than
2242              * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2243              * any CxLVAL() flags that have now been mis-calculated */
2244             cx->blk_u16 = 0;
2245
2246             SAVEI32(PL_debug);
2247             PL_debug = 0;
2248             SAVESTACK_POS();
2249             CvDEPTH(cv)++;
2250             if (CvDEPTH(cv) >= 2)
2251                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2252             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2253             RETURNOP(CvSTART(cv));
2254         }
2255     }
2256     else
2257         return NORMAL;
2258 }
2259
2260
2261 PP(pp_enter)
2262 {
2263     U8 gimme = GIMME_V;
2264
2265     (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2266     return NORMAL;
2267 }
2268
2269
2270 PP(pp_leave)
2271 {
2272     PERL_CONTEXT *cx;
2273     SV **oldsp;
2274     U8 gimme;
2275
2276     cx = CX_CUR();
2277     assert(CxTYPE(cx) == CXt_BLOCK);
2278
2279     if (PL_op->op_flags & OPf_SPECIAL)
2280         /* fake block should preserve $1 et al; e.g.  /(...)/ while ...; */
2281         cx->blk_oldpm = PL_curpm;
2282
2283     oldsp = PL_stack_base + cx->blk_oldsp;
2284     gimme = cx->blk_gimme;
2285
2286     if (gimme == G_VOID)
2287         PL_stack_sp = oldsp;
2288     else
2289         leave_adjust_stacks(oldsp, oldsp, gimme,
2290                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2291
2292     CX_LEAVE_SCOPE(cx);
2293     cx_popblock(cx);
2294     CX_POP(cx);
2295
2296     return NORMAL;
2297 }
2298
2299 static bool
2300 S_outside_integer(pTHX_ SV *sv)
2301 {
2302   if (SvOK(sv)) {
2303     const NV nv = SvNV_nomg(sv);
2304     if (Perl_isinfnan(nv))
2305       return TRUE;
2306 #ifdef NV_PRESERVES_UV
2307     if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2308       return TRUE;
2309 #else
2310     if (nv <= (NV)IV_MIN)
2311       return TRUE;
2312     if ((nv > 0) &&
2313         ((nv > (NV)UV_MAX ||
2314           SvUV_nomg(sv) > (UV)IV_MAX)))
2315       return TRUE;
2316 #endif
2317   }
2318   return FALSE;
2319 }
2320
2321 PP(pp_enteriter)
2322 {
2323     dSP; dMARK;
2324     PERL_CONTEXT *cx;
2325     const U8 gimme = GIMME_V;
2326     void *itervarp; /* GV or pad slot of the iteration variable */
2327     SV   *itersave; /* the old var in the iterator var slot */
2328     U8 cxflags = 0;
2329
2330     if (PL_op->op_targ) {                        /* "my" variable */
2331         itervarp = &PAD_SVl(PL_op->op_targ);
2332         itersave = *(SV**)itervarp;
2333         assert(itersave);
2334         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2335             /* the SV currently in the pad slot is never live during
2336              * iteration (the slot is always aliased to one of the items)
2337              * so it's always stale */
2338             SvPADSTALE_on(itersave);
2339         }
2340         SvREFCNT_inc_simple_void_NN(itersave);
2341         cxflags = CXp_FOR_PAD;
2342     }
2343     else {
2344         SV * const sv = POPs;
2345         itervarp = (void *)sv;
2346         if (LIKELY(isGV(sv))) {         /* symbol table variable */
2347             SvREFCNT_inc_simple_void(sv);
2348             itersave = GvSV(sv);
2349             SvREFCNT_inc_simple_void(itersave);
2350             cxflags = CXp_FOR_GV;
2351             if (PL_op->op_private & OPpITER_DEF)
2352                 cxflags |= CXp_FOR_DEF;
2353         }
2354         else {                          /* LV ref: for \$foo (...) */
2355             assert(SvTYPE(sv) == SVt_PVMG);
2356             assert(SvMAGIC(sv));
2357             assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2358             itersave = NULL;
2359             cxflags = CXp_FOR_LVREF;
2360             SvREFCNT_inc_simple_void(sv);
2361         }
2362     }
2363     /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2364     assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2365
2366     /* Note that this context is initially set as CXt_NULL. Further on
2367      * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2368      * there mustn't be anything in the blk_loop substruct that requires
2369      * freeing or undoing, in case we die in the meantime. And vice-versa.
2370      */
2371     cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2372     cx_pushloop_for(cx, itervarp, itersave);
2373
2374     if (PL_op->op_flags & OPf_STACKED) {
2375         /* OPf_STACKED implies either a single array: for(@), with a
2376          * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2377          * the stack */
2378         SV *maybe_ary = POPs;
2379         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2380             /* range */
2381             dPOPss;
2382             SV * const right = maybe_ary;
2383             if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2384                 DIE(aTHX_ "Assigned value is not a reference");
2385             SvGETMAGIC(sv);
2386             SvGETMAGIC(right);
2387             if (RANGE_IS_NUMERIC(sv,right)) {
2388                 cx->cx_type |= CXt_LOOP_LAZYIV;
2389                 if (S_outside_integer(aTHX_ sv) ||
2390                     S_outside_integer(aTHX_ right))
2391                     DIE(aTHX_ "Range iterator outside integer range");
2392                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2393                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2394             }
2395             else {
2396                 cx->cx_type |= CXt_LOOP_LAZYSV;
2397                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2398                 cx->blk_loop.state_u.lazysv.end = right;
2399                 SvREFCNT_inc_simple_void_NN(right);
2400                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2401                 /* This will do the upgrade to SVt_PV, and warn if the value
2402                    is uninitialised.  */
2403                 (void) SvPV_nolen_const(right);
2404                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2405                    to replace !SvOK() with a pointer to "".  */
2406                 if (!SvOK(right)) {
2407                     SvREFCNT_dec(right);
2408                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2409                 }
2410             }
2411         }
2412         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2413             /* for (@array) {} */
2414             cx->cx_type |= CXt_LOOP_ARY;
2415             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2416             SvREFCNT_inc_simple_void_NN(maybe_ary);
2417             cx->blk_loop.state_u.ary.ix =
2418                 (PL_op->op_private & OPpITER_REVERSED) ?
2419                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2420                 -1;
2421         }
2422         /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2423     }
2424     else { /* iterating over items on the stack */
2425         cx->cx_type |= CXt_LOOP_LIST;
2426         cx->blk_oldsp = SP - PL_stack_base;
2427         cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2428         cx->blk_loop.state_u.stack.ix =
2429             (PL_op->op_private & OPpITER_REVERSED)
2430                 ? cx->blk_oldsp + 1
2431                 : cx->blk_loop.state_u.stack.basesp;
2432         /* pre-extend stack so pp_iter doesn't have to check every time
2433          * it pushes yes/no */
2434         EXTEND(SP, 1);
2435     }
2436
2437     RETURN;
2438 }
2439
2440 PP(pp_enterloop)
2441 {
2442     PERL_CONTEXT *cx;
2443     const U8 gimme = GIMME_V;
2444
2445     cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2446     cx_pushloop_plain(cx);
2447     return NORMAL;
2448 }
2449
2450
2451 PP(pp_leaveloop)
2452 {
2453     PERL_CONTEXT *cx;
2454     U8 gimme;
2455     SV **base;
2456     SV **oldsp;
2457
2458     cx = CX_CUR();
2459     assert(CxTYPE_is_LOOP(cx));
2460     oldsp = PL_stack_base + cx->blk_oldsp;
2461     base = CxTYPE(cx) == CXt_LOOP_LIST
2462                 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2463                 : oldsp;
2464     gimme = cx->blk_gimme;
2465
2466     if (gimme == G_VOID)
2467         PL_stack_sp = base;
2468     else
2469         leave_adjust_stacks(oldsp, base, gimme,
2470                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2471
2472     CX_LEAVE_SCOPE(cx);
2473     cx_poploop(cx);     /* Stack values are safe: release loop vars ... */
2474     cx_popblock(cx);
2475     CX_POP(cx);
2476
2477     return NORMAL;
2478 }
2479
2480
2481 /* This duplicates most of pp_leavesub, but with additional code to handle
2482  * return args in lvalue context. It was forked from pp_leavesub to
2483  * avoid slowing down that function any further.
2484  *
2485  * Any changes made to this function may need to be copied to pp_leavesub
2486  * and vice-versa.
2487  *
2488  * also tail-called by pp_return
2489  */
2490
2491 PP(pp_leavesublv)
2492 {
2493     U8 gimme;
2494     PERL_CONTEXT *cx;
2495     SV **oldsp;
2496     OP *retop;
2497
2498     cx = CX_CUR();
2499     assert(CxTYPE(cx) == CXt_SUB);
2500
2501     if (CxMULTICALL(cx)) {
2502         /* entry zero of a stack is always PL_sv_undef, which
2503          * simplifies converting a '()' return into undef in scalar context */
2504         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2505         return 0;
2506     }
2507
2508     gimme = cx->blk_gimme;
2509     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2510
2511     if (gimme == G_VOID)
2512         PL_stack_sp = oldsp;
2513     else {
2514         U8   lval    = CxLVAL(cx);
2515         bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2516         const char *what = NULL;
2517
2518         if (gimme == G_SCALAR) {
2519             if (is_lval) {
2520                 /* check for bad return arg */
2521                 if (oldsp < PL_stack_sp) {
2522                     SV *sv = *PL_stack_sp;
2523                     if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2524                         what =
2525                             SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2526                             : "a readonly value" : "a temporary";
2527                     }
2528                     else goto ok;
2529                 }
2530                 else {
2531                     /* sub:lvalue{} will take us here. */
2532                     what = "undef";
2533                 }
2534               croak:
2535                 Perl_croak(aTHX_
2536                           "Can't return %s from lvalue subroutine", what);
2537             }
2538
2539           ok:
2540             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2541
2542             if (lval & OPpDEREF) {
2543                 /* lval_sub()->{...} and similar */
2544                 dSP;
2545                 SvGETMAGIC(TOPs);
2546                 if (!SvOK(TOPs)) {
2547                     TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2548                 }
2549                 PUTBACK;
2550             }
2551         }
2552         else {
2553             assert(gimme == G_LIST);
2554             assert (!(lval & OPpDEREF));
2555
2556             if (is_lval) {
2557                 /* scan for bad return args */
2558                 SV **p;
2559                 for (p = PL_stack_sp; p > oldsp; p--) {
2560                     SV *sv = *p;
2561                     /* the PL_sv_undef exception is to allow things like
2562                      * this to work, where PL_sv_undef acts as 'skip'
2563                      * placeholder on the LHS of list assigns:
2564                      *    sub foo :lvalue { undef }
2565                      *    ($a, undef, foo(), $b) = 1..4;
2566                      */
2567                     if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2568                     {
2569                         /* Might be flattened array after $#array =  */
2570                         what = SvREADONLY(sv)
2571                                 ? "a readonly value" : "a temporary";
2572                         goto croak;
2573                     }
2574                 }
2575             }
2576
2577             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2578         }
2579     }
2580
2581     CX_LEAVE_SCOPE(cx);
2582     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
2583     cx_popblock(cx);
2584     retop =  cx->blk_sub.retop;
2585     CX_POP(cx);
2586
2587     return retop;
2588 }
2589
2590 static const char *S_defer_blockname(PERL_CONTEXT *cx)
2591 {
2592     return (cx->cx_type & CXp_FINALLY) ? "finally" : "defer";
2593 }
2594
2595
2596 PP(pp_return)
2597 {
2598     dSP; dMARK;
2599     PERL_CONTEXT *cx;
2600     I32 cxix = dopopto_cursub();
2601
2602     assert(cxstack_ix >= 0);
2603     if (cxix < cxstack_ix) {
2604         I32 i;
2605         /* Check for  defer { return; } */
2606         for(i = cxstack_ix; i > cxix; i--) {
2607             if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2608                 /* diag_listed_as: Can't "%s" out of a "defer" block */
2609                 /* diag_listed_as: Can't "%s" out of a "finally" block */
2610                 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2611                         "return", S_defer_blockname(&cxstack[i]));
2612         }
2613         if (cxix < 0) {
2614             if (!(       PL_curstackinfo->si_type == PERLSI_SORT
2615                   || (   PL_curstackinfo->si_type == PERLSI_MULTICALL
2616                       && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2617                  )
2618             )
2619                 DIE(aTHX_ "Can't return outside a subroutine");
2620             /* We must be in:
2621              *  a sort block, which is a CXt_NULL not a CXt_SUB;
2622              *  or a /(?{...})/ block.
2623              * Handle specially. */
2624             assert(CxTYPE(&cxstack[0]) == CXt_NULL
2625                     || (   CxTYPE(&cxstack[0]) == CXt_SUB
2626                         && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2627             if (cxstack_ix > 0) {
2628                 /* See comment below about context popping. Since we know
2629                  * we're scalar and not lvalue, we can preserve the return
2630                  * value in a simpler fashion than there. */
2631                 SV *sv = *SP;
2632                 assert(cxstack[0].blk_gimme == G_SCALAR);
2633                 if (   (sp != PL_stack_base)
2634                     && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2635                 )
2636                     *SP = sv_mortalcopy(sv);
2637                 dounwind(0);
2638             }
2639             /* caller responsible for popping cxstack[0] */
2640             return 0;
2641         }
2642
2643         /* There are contexts that need popping. Doing this may free the
2644          * return value(s), so preserve them first: e.g. popping the plain
2645          * loop here would free $x:
2646          *     sub f {  { my $x = 1; return $x } }
2647          * We may also need to shift the args down; for example,
2648          *    for (1,2) { return 3,4 }
2649          * leaves 1,2,3,4 on the stack. Both these actions will be done by
2650          * leave_adjust_stacks(), along with freeing any temps. Note that
2651          * whoever we tail-call (e.g. pp_leaveeval) will also call
2652          * leave_adjust_stacks(); however, the second call is likely to
2653          * just see a bunch of SvTEMPs with a ref count of 1, and so just
2654          * pass them through, rather than copying them again. So this
2655          * isn't as inefficient as it sounds.
2656          */
2657         cx = &cxstack[cxix];
2658         PUTBACK;
2659         if (cx->blk_gimme != G_VOID)
2660             leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2661                     cx->blk_gimme,
2662                     CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2663                         ? 3 : 0);
2664         SPAGAIN;
2665         dounwind(cxix);
2666         cx = &cxstack[cxix]; /* CX stack may have been realloced */
2667     }
2668     else {
2669         /* Like in the branch above, we need to handle any extra junk on
2670          * the stack. But because we're not also popping extra contexts, we
2671          * don't have to worry about prematurely freeing args. So we just
2672          * need to do the bare minimum to handle junk, and leave the main
2673          * arg processing in the function we tail call, e.g. pp_leavesub.
2674          * In list context we have to splice out the junk; in scalar
2675          * context we can leave as-is (pp_leavesub will later return the
2676          * top stack element). But for an  empty arg list, e.g.
2677          *    for (1,2) { return }
2678          * we need to set sp = oldsp so that pp_leavesub knows to push
2679          * &PL_sv_undef onto the stack.
2680          */
2681         SV **oldsp;
2682         cx = &cxstack[cxix];
2683         oldsp = PL_stack_base + cx->blk_oldsp;
2684         if (oldsp != MARK) {
2685             SSize_t nargs = SP - MARK;
2686             if (nargs) {
2687                 if (cx->blk_gimme == G_LIST) {
2688                     /* shift return args to base of call stack frame */
2689                     Move(MARK + 1, oldsp + 1, nargs, SV*);
2690                     PL_stack_sp  = oldsp + nargs;
2691                 }
2692             }
2693             else
2694                 PL_stack_sp  = oldsp;
2695         }
2696     }
2697
2698     /* fall through to a normal exit */
2699     switch (CxTYPE(cx)) {
2700     case CXt_EVAL:
2701         return CxEVALBLOCK(cx)
2702             ? Perl_pp_leavetry(aTHX)
2703             : Perl_pp_leaveeval(aTHX);
2704     case CXt_SUB:
2705         return CvLVALUE(cx->blk_sub.cv)
2706             ? Perl_pp_leavesublv(aTHX)
2707             : Perl_pp_leavesub(aTHX);
2708     case CXt_FORMAT:
2709         return Perl_pp_leavewrite(aTHX);
2710     default:
2711         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2712     }
2713 }
2714
2715 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2716
2717 static PERL_CONTEXT *
2718 S_unwind_loop(pTHX)
2719 {
2720     I32 cxix;
2721     if (PL_op->op_flags & OPf_SPECIAL) {
2722         cxix = dopoptoloop(cxstack_ix);
2723         if (cxix < 0)
2724             /* diag_listed_as: Can't "last" outside a loop block */
2725             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2726                 OP_NAME(PL_op));
2727     }
2728     else {
2729         STRLEN label_len;
2730         const char * label;
2731         U32 label_flags;
2732         SV *sv;
2733
2734         if (PL_op->op_flags & OPf_STACKED) {
2735             dSP;
2736             sv = POPs;
2737             PUTBACK;
2738             label       = SvPV(sv, label_len);
2739             label_flags = SvUTF8(sv);
2740         }
2741         else {
2742             sv          = NULL; /* not needed, but shuts up compiler warn */
2743             label       = cPVOP->op_pv;
2744             label_len   = strlen(label);
2745             label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2746         }
2747
2748         cxix = dopoptolabel(label, label_len, label_flags);
2749         if (cxix < 0)
2750             /* diag_listed_as: Label not found for "last %s" */
2751             Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2752                                        OP_NAME(PL_op),
2753                                        SVfARG(PL_op->op_flags & OPf_STACKED
2754                                               && !SvGMAGICAL(sv)
2755                                               ? sv
2756                                               : newSVpvn_flags(label,
2757                                                     label_len,
2758                                                     label_flags | SVs_TEMP)));
2759     }
2760     if (cxix < cxstack_ix) {
2761         I32 i;
2762         /* Check for  defer { last ... } etc */
2763         for(i = cxstack_ix; i > cxix; i--) {
2764             if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2765                 /* diag_listed_as: Can't "%s" out of a "defer" block */
2766                 /* diag_listed_as: Can't "%s" out of a "finally" block */
2767                 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2768                         OP_NAME(PL_op), S_defer_blockname(&cxstack[i]));
2769         }
2770         dounwind(cxix);
2771     }
2772     return &cxstack[cxix];
2773 }
2774
2775
2776 PP(pp_last)
2777 {
2778     PERL_CONTEXT *cx;
2779     OP* nextop;
2780
2781     cx = S_unwind_loop(aTHX);
2782
2783     assert(CxTYPE_is_LOOP(cx));
2784     PL_stack_sp = PL_stack_base
2785                 + (CxTYPE(cx) == CXt_LOOP_LIST
2786                     ?  cx->blk_loop.state_u.stack.basesp
2787                     : cx->blk_oldsp
2788                 );
2789
2790     TAINT_NOT;
2791
2792     /* Stack values are safe: */
2793     CX_LEAVE_SCOPE(cx);
2794     cx_poploop(cx);     /* release loop vars ... */
2795     cx_popblock(cx);
2796     nextop = cx->blk_loop.my_op->op_lastop->op_next;
2797     CX_POP(cx);
2798
2799     return nextop;
2800 }
2801
2802 PP(pp_next)
2803 {
2804     PERL_CONTEXT *cx;
2805
2806     /* if not a bare 'next' in the main scope, search for it */
2807     cx = CX_CUR();
2808     if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2809         cx = S_unwind_loop(aTHX);
2810
2811     cx_topblock(cx);
2812     PL_curcop = cx->blk_oldcop;
2813     PERL_ASYNC_CHECK();
2814     return (cx)->blk_loop.my_op->op_nextop;
2815 }
2816
2817 PP(pp_redo)
2818 {
2819     PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2820     OP* redo_op = cx->blk_loop.my_op->op_redoop;
2821
2822     if (redo_op->op_type == OP_ENTER) {
2823         /* pop one less context to avoid $x being freed in while (my $x..) */
2824         cxstack_ix++;
2825         cx = CX_CUR();
2826         assert(CxTYPE(cx) == CXt_BLOCK);
2827         redo_op = redo_op->op_next;
2828     }
2829
2830     FREETMPS;
2831     CX_LEAVE_SCOPE(cx);
2832     cx_topblock(cx);
2833     PL_curcop = cx->blk_oldcop;
2834     PERL_ASYNC_CHECK();
2835     return redo_op;
2836 }
2837
2838 #define UNENTERABLE (OP *)1
2839 #define GOTO_DEPTH 64
2840
2841 STATIC OP *
2842 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2843 {
2844     OP **ops = opstack;
2845     static const char* const too_deep = "Target of goto is too deeply nested";
2846
2847     PERL_ARGS_ASSERT_DOFINDLABEL;
2848
2849     if (ops >= oplimit)
2850         Perl_croak(aTHX_ "%s", too_deep);
2851     if (o->op_type == OP_LEAVE ||
2852         o->op_type == OP_SCOPE ||
2853         o->op_type == OP_LEAVELOOP ||
2854         o->op_type == OP_LEAVESUB ||
2855         o->op_type == OP_LEAVETRY ||
2856         o->op_type == OP_LEAVEGIVEN)
2857     {
2858         *ops++ = cUNOPo->op_first;
2859     }
2860     else if (oplimit - opstack < GOTO_DEPTH) {
2861       if (o->op_flags & OPf_KIDS
2862           && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2863         *ops++ = UNENTERABLE;
2864       }
2865       else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2866           && OP_CLASS(o) != OA_LOGOP
2867           && o->op_type != OP_LINESEQ
2868           && o->op_type != OP_SREFGEN
2869           && o->op_type != OP_ENTEREVAL
2870           && o->op_type != OP_GLOB
2871           && o->op_type != OP_RV2CV) {
2872         OP * const kid = cUNOPo->op_first;
2873         if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2874             *ops++ = UNENTERABLE;
2875       }
2876     }
2877     if (ops >= oplimit)
2878         Perl_croak(aTHX_ "%s", too_deep);
2879     *ops = 0;
2880     if (o->op_flags & OPf_KIDS) {
2881         OP *kid;
2882         OP * const kid1 = cUNOPo->op_first;
2883         /* First try all the kids at this level, since that's likeliest. */
2884         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2885             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2886                 STRLEN kid_label_len;
2887                 U32 kid_label_flags;
2888                 const char *kid_label = CopLABEL_len_flags(kCOP,
2889                                                     &kid_label_len, &kid_label_flags);
2890                 if (kid_label && (
2891                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2892                         (flags & SVf_UTF8)
2893                             ? (bytes_cmp_utf8(
2894                                         (const U8*)kid_label, kid_label_len,
2895                                         (const U8*)label, len) == 0)
2896                             : (bytes_cmp_utf8(
2897                                         (const U8*)label, len,
2898                                         (const U8*)kid_label, kid_label_len) == 0)
2899                     : ( len == kid_label_len && ((kid_label == label)
2900                                     || memEQ(kid_label, label, len)))))
2901                     return kid;
2902             }
2903         }
2904         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2905             bool first_kid_of_binary = FALSE;
2906             if (kid == PL_lastgotoprobe)
2907                 continue;
2908             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2909                 if (ops == opstack)
2910                     *ops++ = kid;
2911                 else if (ops[-1] != UNENTERABLE
2912                       && (ops[-1]->op_type == OP_NEXTSTATE ||
2913                           ops[-1]->op_type == OP_DBSTATE))
2914                     ops[-1] = kid;
2915                 else
2916                     *ops++ = kid;
2917             }
2918             if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2919                 first_kid_of_binary = TRUE;
2920                 ops--;
2921             }
2922             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) {
2923                 if (kid->op_type == OP_PUSHDEFER)
2924                     Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block");
2925                 return o;
2926             }
2927             if (first_kid_of_binary)
2928                 *ops++ = UNENTERABLE;
2929         }
2930     }
2931     *ops = 0;
2932     return 0;
2933 }
2934
2935
2936 static void
2937 S_check_op_type(pTHX_ OP * const o)
2938 {
2939     /* Eventually we may want to stack the needed arguments
2940      * for each op.  For now, we punt on the hard ones. */
2941     /* XXX This comment seems to me like wishful thinking.  --sprout */
2942     if (o == UNENTERABLE)
2943         Perl_croak(aTHX_
2944                   "Can't \"goto\" into a binary or list expression");
2945     if (o->op_type == OP_ENTERITER)
2946         Perl_croak(aTHX_
2947                   "Can't \"goto\" into the middle of a foreach loop");
2948     if (o->op_type == OP_ENTERGIVEN)
2949         Perl_croak(aTHX_
2950                   "Can't \"goto\" into a \"given\" block");
2951 }
2952
2953 /* also used for: pp_dump() */
2954
2955 PP(pp_goto)
2956 {
2957     dSP;
2958     OP *retop = NULL;
2959     I32 ix;
2960     PERL_CONTEXT *cx;
2961     OP *enterops[GOTO_DEPTH];
2962     const char *label = NULL;
2963     STRLEN label_len = 0;
2964     U32 label_flags = 0;
2965     const bool do_dump = (PL_op->op_type == OP_DUMP);
2966     static const char* const must_have_label = "goto must have label";
2967
2968     if (PL_op->op_flags & OPf_STACKED) {
2969         /* goto EXPR  or  goto &foo */
2970
2971         SV * const sv = POPs;
2972         SvGETMAGIC(sv);
2973
2974         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2975             /* This egregious kludge implements goto &subroutine */
2976             I32 cxix;
2977             PERL_CONTEXT *cx;
2978             CV *cv = MUTABLE_CV(SvRV(sv));
2979             AV *arg = GvAV(PL_defgv);
2980             CV *old_cv = NULL;
2981
2982             while (!CvROOT(cv) && !CvXSUB(cv)) {
2983                 const GV * const gv = CvGV(cv);
2984                 if (gv) {
2985                     GV *autogv;
2986                     SV *tmpstr;
2987                     /* autoloaded stub? */
2988                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2989                         continue;
2990                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2991                                           GvNAMELEN(gv),
2992                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2993                     if (autogv && (cv = GvCV(autogv)))
2994                         continue;
2995                     tmpstr = sv_newmortal();
2996                     gv_efullname3(tmpstr, gv, NULL);
2997                     DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2998                 }
2999                 DIE(aTHX_ "Goto undefined subroutine");
3000             }
3001
3002             cxix = dopopto_cursub();
3003             if (cxix < 0) {
3004                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
3005             }
3006             cx  = &cxstack[cxix];
3007             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
3008             if (CxTYPE(cx) == CXt_EVAL) {
3009                 if (CxREALEVAL(cx))
3010                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3011                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
3012                 else
3013                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3014                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
3015             }
3016             else if (CxMULTICALL(cx))
3017                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
3018
3019             /* Check for  defer { goto &...; } */
3020             for(ix = cxstack_ix; ix > cxix; ix--) {
3021                 if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
3022                     /* diag_listed_as: Can't "%s" out of a "defer" block */
3023                     Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
3024                             "goto", S_defer_blockname(&cxstack[ix]));
3025             }
3026
3027             /* First do some returnish stuff. */
3028
3029             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
3030             FREETMPS;
3031             if (cxix < cxstack_ix) {
3032                 dounwind(cxix);
3033             }
3034             cx = CX_CUR();
3035             cx_topblock(cx);
3036             SPAGAIN;
3037
3038             /* protect @_ during save stack unwind. */
3039             if (arg)
3040                 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
3041
3042             assert(PL_scopestack_ix == cx->blk_oldscopesp);
3043             CX_LEAVE_SCOPE(cx);
3044
3045             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3046                 /* this is part of cx_popsub_args() */
3047                 AV* av = MUTABLE_AV(PAD_SVl(0));
3048                 assert(AvARRAY(MUTABLE_AV(
3049                     PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
3050                             CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
3051
3052                 /* we are going to donate the current @_ from the old sub
3053                  * to the new sub. This first part of the donation puts a
3054                  * new empty AV in the pad[0] slot of the old sub,
3055                  * unless pad[0] and @_ differ (e.g. if the old sub did
3056                  * local *_ = []); in which case clear the old pad[0]
3057                  * array in the usual way */
3058                 if (av == arg || AvREAL(av))
3059                     clear_defarray(av, av == arg);
3060                 else CLEAR_ARGARRAY(av);
3061             }
3062
3063             /* don't restore PL_comppad here. It won't be needed if the
3064              * sub we're going to is non-XS, but restoring it early then
3065              * croaking (e.g. the "Goto undefined subroutine" below)
3066              * means the CX block gets processed again in dounwind,
3067              * but this time with the wrong PL_comppad */
3068
3069             /* A destructor called during LEAVE_SCOPE could have undefined
3070              * our precious cv.  See bug #99850. */
3071             if (!CvROOT(cv) && !CvXSUB(cv)) {
3072                 const GV * const gv = CvGV(cv);
3073                 if (gv) {
3074                     SV * const tmpstr = sv_newmortal();
3075                     gv_efullname3(tmpstr, gv, NULL);
3076                     DIE(aTHX_ "Goto undefined subroutine &%" SVf,
3077                                SVfARG(tmpstr));
3078                 }
3079                 DIE(aTHX_ "Goto undefined subroutine");
3080             }
3081
3082             if (CxTYPE(cx) == CXt_SUB) {
3083                 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
3084                 /*on XS calls defer freeing the old CV as it could
3085                  * prematurely set PL_op to NULL, which could cause
3086                  * e..g XS subs using GIMME_V to SEGV */
3087                 if (CvISXSUB(cv))
3088                     old_cv = cx->blk_sub.cv;
3089                 else
3090                     SvREFCNT_dec_NN(cx->blk_sub.cv);
3091             }
3092
3093             /* Now do some callish stuff. */
3094             if (CvISXSUB(cv)) {
3095                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
3096                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
3097                 SV** mark;
3098                 UNOP fake_goto_op;
3099
3100                 ENTER;
3101                 SAVETMPS;
3102                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3103                 if (old_cv)
3104                     SAVEFREESV(old_cv); /* ditto, deferred freeing of old CV */
3105
3106                 /* put GvAV(defgv) back onto stack */
3107                 if (items) {
3108                     EXTEND(SP, items+1); /* @_ could have been extended. */
3109                 }
3110                 mark = SP;
3111                 if (items) {
3112                     SSize_t index;
3113                     bool r = cBOOL(AvREAL(arg));
3114                     for (index=0; index<items; index++)
3115                     {
3116                         SV *sv;
3117                         if (m) {
3118                             SV ** const svp = av_fetch(arg, index, 0);
3119                             sv = svp ? *svp : NULL;
3120                         }
3121                         else sv = AvARRAY(arg)[index];
3122                         SP[index+1] = sv
3123                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
3124                             : sv_2mortal(newSVavdefelem(arg, index, 1));
3125                     }
3126                 }
3127                 SP += items;
3128                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3129                     /* Restore old @_ */
3130                     CX_POP_SAVEARRAY(cx);
3131                 }
3132
3133                 retop = cx->blk_sub.retop;
3134                 PL_comppad = cx->blk_sub.prevcomppad;
3135                 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
3136
3137                 /* Make a temporary a copy of the current GOTO op on the C
3138                  * stack, but with a modified gimme (we can't modify the
3139                  * real GOTO op as that's not thread-safe). This allows XS
3140                  * users of GIMME_V to get the correct calling context,
3141                  * even though there is no longer a CXt_SUB frame to
3142                  * provide that information.
3143                  */
3144                 Copy(PL_op, &fake_goto_op, 1, UNOP);
3145                 fake_goto_op.op_flags =
3146                                   (fake_goto_op.op_flags & ~OPf_WANT)
3147                                 | (cx->blk_gimme & G_WANT);
3148                 PL_op = (OP*)&fake_goto_op;
3149
3150                 /* XS subs don't have a CXt_SUB, so pop it;
3151                  * this is a cx_popblock(), less all the stuff we already did
3152                  * for cx_topblock() earlier */
3153                 PL_curcop = cx->blk_oldcop;
3154                 /* this is cx_popsub, less all the stuff we already did */
3155                 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
3156
3157                 CX_POP(cx);
3158
3159                 /* Push a mark for the start of arglist */
3160                 PUSHMARK(mark);
3161                 PUTBACK;
3162                 (void)(*CvXSUB(cv))(aTHX_ cv);
3163                 LEAVE;
3164                 goto _return;
3165             }
3166             else {
3167                 PADLIST * const padlist = CvPADLIST(cv);
3168
3169                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3170
3171                 /* partial unrolled cx_pushsub(): */
3172
3173                 cx->blk_sub.cv = cv;
3174                 cx->blk_sub.olddepth = CvDEPTH(cv);
3175
3176                 CvDEPTH(cv)++;
3177                 SvREFCNT_inc_simple_void_NN(cv);
3178                 if (CvDEPTH(cv) > 1) {
3179                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
3180                         sub_crush_depth(cv);
3181                     pad_push(padlist, CvDEPTH(cv));
3182                 }
3183                 PL_curcop = cx->blk_oldcop;
3184                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
3185                 if (CxHASARGS(cx))
3186                 {
3187                     /* second half of donating @_ from the old sub to the
3188                      * new sub: abandon the original pad[0] AV in the
3189                      * new sub, and replace it with the donated @_.
3190                      * pad[0] takes ownership of the extra refcount
3191                      * we gave arg earlier */
3192                     if (arg) {
3193                         SvREFCNT_dec(PAD_SVl(0));
3194                         PAD_SVl(0) = (SV *)arg;
3195                         SvREFCNT_inc_simple_void_NN(arg);
3196                     }
3197
3198                     /* GvAV(PL_defgv) might have been modified on scope
3199                        exit, so point it at arg again. */
3200                     if (arg != GvAV(PL_defgv)) {
3201                         AV * const av = GvAV(PL_defgv);
3202                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3203                         SvREFCNT_dec(av);
3204                     }
3205                 }
3206
3207                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
3208                     Perl_get_db_sub(aTHX_ NULL, cv);
3209                     if (PERLDB_GOTO) {
3210                         CV * const gotocv = get_cvs("DB::goto", 0);
3211                         if (gotocv) {
3212                             PUSHMARK( PL_stack_sp );
3213                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3214                             PL_stack_sp--;
3215                         }
3216                     }
3217                 }
3218                 retop = CvSTART(cv);
3219                 goto putback_return;
3220             }
3221         }
3222         else {
3223             /* goto EXPR */
3224             label       = SvPV_nomg_const(sv, label_len);
3225             label_flags = SvUTF8(sv);
3226         }
3227     }
3228     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3229         /* goto LABEL  or  dump LABEL */
3230         label       = cPVOP->op_pv;
3231         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3232         label_len   = strlen(label);
3233     }
3234     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3235
3236     PERL_ASYNC_CHECK();
3237
3238     if (label_len) {
3239         OP *gotoprobe = NULL;
3240         bool leaving_eval = FALSE;
3241         bool in_block = FALSE;
3242         bool pseudo_block = FALSE;
3243         PERL_CONTEXT *last_eval_cx = NULL;
3244
3245         /* find label */
3246
3247         PL_lastgotoprobe = NULL;
3248         *enterops = 0;
3249         for (ix = cxstack_ix; ix >= 0; ix--) {
3250             cx = &cxstack[ix];
3251             switch (CxTYPE(cx)) {
3252             case CXt_EVAL:
3253                 leaving_eval = TRUE;
3254                 if (!CxEVALBLOCK(cx)) {
3255                     gotoprobe = (last_eval_cx ?
3256                                 last_eval_cx->blk_eval.old_eval_root :
3257                                 PL_eval_root);
3258                     last_eval_cx = cx;
3259                     break;
3260                 }
3261                 /* else fall through */
3262             case CXt_LOOP_PLAIN:
3263             case CXt_LOOP_LAZYIV:
3264             case CXt_LOOP_LAZYSV:
3265             case CXt_LOOP_LIST:
3266             case CXt_LOOP_ARY:
3267             case CXt_GIVEN:
3268             case CXt_WHEN:
3269                 gotoprobe = OpSIBLING(cx->blk_oldcop);
3270                 break;
3271             case CXt_SUBST:
3272                 continue;
3273             case CXt_BLOCK:
3274                 if (ix) {
3275                     gotoprobe = OpSIBLING(cx->blk_oldcop);
3276                     in_block = TRUE;
3277                 } else
3278                     gotoprobe = PL_main_root;
3279                 break;
3280             case CXt_SUB:
3281                 gotoprobe = CvROOT(cx->blk_sub.cv);
3282                 pseudo_block = cBOOL(CxMULTICALL(cx));
3283                 break;
3284             case CXt_FORMAT:
3285             case CXt_NULL:
3286                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3287             case CXt_DEFER:
3288                 /* diag_listed_as: Can't "%s" out of a "defer" block */
3289                 DIE(aTHX_ "Can't \"%s\" out of a \"%s\" block", "goto", S_defer_blockname(cx));
3290             default:
3291                 if (ix)
3292                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3293                         CxTYPE(cx), (long) ix);
3294                 gotoprobe = PL_main_root;
3295                 break;
3296             }
3297             if (gotoprobe) {
3298                 OP *sibl1, *sibl2;
3299
3300                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3301                                     enterops, enterops + GOTO_DEPTH);
3302                 if (retop)
3303                     break;
3304                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3305                      sibl1->op_type == OP_UNSTACK &&
3306                      (sibl2 = OpSIBLING(sibl1)))
3307                 {
3308                     retop = dofindlabel(sibl2,
3309                                         label, label_len, label_flags, enterops,
3310                                         enterops + GOTO_DEPTH);
3311                     if (retop)
3312                         break;
3313                 }
3314             }
3315             if (pseudo_block)
3316                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3317             PL_lastgotoprobe = gotoprobe;
3318         }
3319         if (!retop)
3320             DIE(aTHX_ "Can't find label %" UTF8f,
3321                        UTF8fARG(label_flags, label_len, label));
3322
3323         /* if we're leaving an eval, check before we pop any frames
3324            that we're not going to punt, otherwise the error
3325            won't be caught */
3326
3327         if (leaving_eval && *enterops && enterops[1]) {
3328             I32 i;
3329             for (i = 1; enterops[i]; i++)
3330                 S_check_op_type(aTHX_ enterops[i]);
3331         }
3332
3333         if (*enterops && enterops[1]) {
3334             I32 i = enterops[1] != UNENTERABLE
3335                  && enterops[1]->op_type == OP_ENTER && in_block
3336                     ? 2
3337                     : 1;
3338             if (enterops[i])
3339                 deprecate(WARN_DEPRECATED__GOTO_CONSTRUCT, "Use of \"goto\" to jump into a construct");
3340         }
3341
3342         /* pop unwanted frames */
3343
3344         if (ix < cxstack_ix) {
3345             if (ix < 0)
3346                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3347             dounwind(ix);
3348             cx = CX_CUR();
3349             cx_topblock(cx);
3350         }
3351
3352         /* push wanted frames */
3353
3354         if (*enterops && enterops[1]) {
3355             OP * const oldop = PL_op;
3356             ix = enterops[1] != UNENTERABLE
3357               && enterops[1]->op_type == OP_ENTER && in_block
3358                    ? 2
3359                    : 1;
3360             for (; enterops[ix]; ix++) {
3361                 PL_op = enterops[ix];
3362                 S_check_op_type(aTHX_ PL_op);
3363                 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3364                                          OP_NAME(PL_op)));
3365                 PL_op->op_ppaddr(aTHX);
3366             }
3367             PL_op = oldop;
3368         }
3369     }
3370
3371     if (do_dump) {
3372 #ifdef VMS
3373         if (!retop) retop = PL_main_start;
3374 #endif
3375         PL_restartop = retop;
3376         PL_do_undump = TRUE;
3377
3378         my_unexec();
3379
3380         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3381         PL_do_undump = FALSE;
3382     }
3383
3384     putback_return:
3385     PL_stack_sp = sp;
3386     _return:
3387     PERL_ASYNC_CHECK();
3388     return retop;
3389 }
3390
3391 PP(pp_exit)
3392 {
3393     dSP;
3394     I32 anum;
3395
3396     if (MAXARG < 1)
3397         anum = 0;
3398     else if (!TOPs) {
3399         anum = 0; (void)POPs;
3400     }
3401     else {
3402         anum = SvIVx(POPs);
3403 #ifdef VMS
3404         if (anum == 1
3405          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3406             anum = 0;
3407         VMSISH_HUSHED  =
3408             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3409 #endif
3410     }
3411     PL_exit_flags |= PERL_EXIT_EXPECTED;
3412     my_exit(anum);
3413     PUSHs(&PL_sv_undef);
3414     RETURN;
3415 }
3416
3417 /* Eval. */
3418
3419 STATIC void
3420 S_save_lines(pTHX_ AV *array, SV *sv)
3421 {
3422     const char *s = SvPVX_const(sv);
3423     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3424     I32 line = 1;
3425
3426     PERL_ARGS_ASSERT_SAVE_LINES;
3427
3428     while (s && s < send) {
3429         const char *t;
3430         SV * const tmpstr = newSV_type(SVt_PVMG);
3431
3432         t = (const char *)memchr(s, '\n', send - s);
3433         if (t)
3434             t++;
3435         else
3436             t = send;
3437
3438         sv_setpvn_fresh(tmpstr, s, t - s);
3439         av_store(array, line++, tmpstr);
3440         s = t;
3441     }
3442 }
3443
3444 /*
3445 =for apidoc docatch
3446
3447 Interpose, for the current op and RUNOPS loop,
3448
3449     - a new JMPENV stack catch frame, and
3450     - an inner RUNOPS loop to run all the remaining ops following the
3451       current PL_op.
3452
3453 Then handle any exceptions raised while in that loop.
3454 For a caught eval at this level, re-enter the loop with the specified
3455 restart op (i.e. the op following the OP_LEAVETRY etc); otherwise re-throw
3456 the exception.
3457
3458 docatch() is intended to be used like this:
3459
3460     PP(pp_entertry)
3461     {
3462         if (CATCH_GET)
3463             return docatch(Perl_pp_entertry);
3464
3465         ... rest of function ...
3466         return PL_op->op_next;
3467     }
3468
3469 If a new catch frame isn't needed, the op behaves normally. Otherwise it
3470 calls docatch(), which recursively calls pp_entertry(), this time with
3471 CATCH_GET() false, so the rest of the body of the entertry is run. Then
3472 docatch() calls CALLRUNOPS() which executes all the ops following the
3473 entertry. When the loop finally finishes, control returns to docatch(),
3474 which pops the JMPENV and returns to the parent pp_entertry(), which
3475 itself immediately returns. Note that *all* subsequent ops are run within
3476 the inner RUNOPS loop, not just the body of the eval. For example, in
3477
3478     sub TIEARRAY { eval {1}; my $x }
3479     tie @a, "main";
3480
3481 at the point the 'my' is executed, the C stack will look something like:
3482
3483     #10 main()
3484     #9  perl_run()              # JMPENV_PUSH level 1 here
3485     #8  S_run_body()
3486     #7  Perl_runops_standard()  # main RUNOPS loop
3487     #6  Perl_pp_tie()
3488     #5  Perl_call_sv()
3489     #4  Perl_runops_standard()  # unguarded RUNOPS loop: no new JMPENV
3490     #3  Perl_pp_entertry()
3491     #2  S_docatch()             # JMPENV_PUSH level 2 here
3492     #1  Perl_runops_standard()  # docatch()'s RUNOPs loop
3493     #0  Perl_pp_padsv()
3494
3495 Basically, any section of the perl core which starts a RUNOPS loop may
3496 make a promise that it will catch any exceptions and restart the loop if
3497 necessary. If it's not prepared to do that (like call_sv() isn't), then
3498 it sets CATCH_GET() to true, so that any later eval-like code knows to
3499 set up a new handler and loop (via docatch()).
3500
3501 See L<perlinterp/"Exception handing"> for further details.
3502
3503 =cut
3504 */
3505
3506 STATIC OP *
3507 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3508 {
3509     int ret;
3510     OP * const oldop = PL_op;
3511     dJMPENV;
3512
3513     assert(CATCH_GET);
3514     JMPENV_PUSH(ret);
3515     assert(!CATCH_GET);
3516
3517     switch (ret) {
3518     case 0: /* normal flow-of-control return from JMPENV_PUSH */
3519
3520         /* re-run the current op, this time executing the full body of the
3521          * pp function */
3522         PL_op = firstpp(aTHX);
3523  redo_body:
3524         if (PL_op) {
3525             CALLRUNOPS(aTHX);
3526         }
3527         break;
3528
3529     case 3: /* an exception raised within an eval */
3530         if (PL_restartjmpenv == PL_top_env) {
3531             /* die caught by an inner eval - continue inner loop */
3532
3533             if (!PL_restartop)
3534                 break;
3535             PL_restartjmpenv = NULL;
3536             PL_op = PL_restartop;
3537             PL_restartop = 0;
3538             goto redo_body;
3539         }
3540         /* FALLTHROUGH */
3541
3542     default:
3543         JMPENV_POP;
3544         PL_op = oldop;
3545         JMPENV_JUMP(ret); /* re-throw the exception */
3546         NOT_REACHED; /* NOTREACHED */
3547     }
3548     JMPENV_POP;
3549     PL_op = oldop;
3550     return NULL;
3551 }
3552
3553
3554 /*
3555 =for apidoc find_runcv
3556
3557 Locate the CV corresponding to the currently executing sub or eval.
3558 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3559 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3560 entered.  (This allows debuggers to eval in the scope of the breakpoint
3561 rather than in the scope of the debugger itself.)
3562
3563 =cut
3564 */
3565
3566 CV*
3567 Perl_find_runcv(pTHX_ U32 *db_seqp)
3568 {
3569     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3570 }
3571
3572 /* If this becomes part of the API, it might need a better name. */
3573 CV *
3574 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3575 {
3576     PERL_SI      *si;
3577     int          level = 0;
3578
3579     if (db_seqp)
3580         *db_seqp =
3581             PL_curcop == &PL_compiling
3582                 ? PL_cop_seqmax
3583                 : PL_curcop->cop_seq;
3584
3585     for (si = PL_curstackinfo; si; si = si->si_prev) {
3586         I32 ix;
3587         for (ix = si->si_cxix; ix >= 0; ix--) {
3588             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3589             CV *cv = NULL;
3590             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3591                 cv = cx->blk_sub.cv;
3592                 /* skip DB:: code */
3593                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3594                     *db_seqp = cx->blk_oldcop->cop_seq;
3595                     continue;
3596                 }
3597                 if (cx->cx_type & CXp_SUB_RE)
3598                     continue;
3599             }
3600             else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3601                 cv = cx->blk_eval.cv;
3602             if (cv) {
3603                 switch (cond) {
3604                 case FIND_RUNCV_padid_eq:
3605                     if (!CvPADLIST(cv)
3606                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3607                         continue;
3608                     return cv;
3609                 case FIND_RUNCV_level_eq:
3610                     if (level++ != arg) continue;
3611                     /* FALLTHROUGH */
3612                 default:
3613                     return cv;
3614                 }
3615             }
3616         }
3617     }
3618     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3619 }
3620
3621
3622 /* S_try_yyparse():
3623  *
3624  * Run yyparse() in a setjmp wrapper. Returns:
3625  *   0: yyparse() successful
3626  *   1: yyparse() failed
3627  *   3: yyparse() died
3628  *
3629  * This is used to trap Perl_croak() calls that are executed
3630  * during the compilation process and before the code has been
3631  * completely compiled. It is expected to be called from
3632  * doeval_compile() only. The parameter 'caller_op' is
3633  * only used in DEBUGGING to validate the logic is working
3634  * correctly.
3635  *
3636  * See also try_run_unitcheck().
3637  *
3638  */
3639 STATIC int
3640 S_try_yyparse(pTHX_ int gramtype, OP *caller_op)
3641 {
3642     /* if we die during compilation PL_restartop and PL_restartjmpenv
3643      * will be set by Perl_die_unwind(). We need to restore their values
3644      * if that happens as they are intended for the case where the code
3645      * compiles and dies during execution, not where it dies during
3646      * compilation. PL_restartop and caller_op->op_next should be the
3647      * same anyway, and when compilation fails then caller_op->op_next is
3648      * used as the next op after the compile.
3649      */
3650     JMPENV *restartjmpenv = PL_restartjmpenv;
3651     OP *restartop = PL_restartop;
3652     dJMPENV;
3653     int ret;
3654     PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3655
3656     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3657     JMPENV_PUSH(ret);
3658     switch (ret) {
3659     case 0:
3660         ret = yyparse(gramtype) ? 1 : 0;
3661         break;
3662     case 3:
3663         /* yyparse() died and we trapped the error. We need to restore
3664          * the old PL_restartjmpenv and PL_restartop values. */
3665         assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3666         PL_restartjmpenv = restartjmpenv;
3667         PL_restartop = restartop;
3668         break;
3669     default:
3670         JMPENV_POP;
3671         JMPENV_JUMP(ret);
3672         NOT_REACHED; /* NOTREACHED */
3673     }
3674     JMPENV_POP;
3675     return ret;
3676 }
3677
3678 /* S_try_run_unitcheck()
3679  *
3680  * Run PL_unitcheckav in a setjmp wrapper via call_list.
3681  * Returns:
3682  *   0: unitcheck blocks ran without error
3683  *   3: a unitcheck block died
3684  *
3685  * This is used to trap Perl_croak() calls that are executed
3686  * during UNITCHECK blocks executed after the compilation
3687  * process has completed but before the code itself has been
3688  * executed via the normal run loops. It is expected to be called
3689  * from doeval_compile() only. The parameter 'caller_op' is
3690  * only used in DEBUGGING to validate the logic is working
3691  * correctly.
3692  *
3693  * See also try_yyparse().
3694  */
3695 STATIC int
3696 S_try_run_unitcheck(pTHX_ OP* caller_op)
3697 {
3698     /* if we die during compilation PL_restartop and PL_restartjmpenv
3699      * will be set by Perl_die_unwind(). We need to restore their values
3700      * if that happens as they are intended for the case where the code
3701      * compiles and dies during execution, not where it dies during
3702      * compilation. UNITCHECK runs after compilation completes, and
3703      * if it dies we will execute the PL_restartop anyway via the
3704      * failed compilation code path. PL_restartop and caller_op->op_next
3705      * should be the same anyway, and when compilation fails then
3706      * caller_op->op_next is  used as the next op after the compile.
3707      */
3708     JMPENV *restartjmpenv = PL_restartjmpenv;
3709     OP *restartop = PL_restartop;
3710     dJMPENV;
3711     int ret;
3712     PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3713
3714     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3715     JMPENV_PUSH(ret);
3716     switch (ret) {
3717     case 0:
3718         call_list(PL_scopestack_ix, PL_unitcheckav);
3719         break;
3720     case 3:
3721         /* call_list died */
3722         /* call_list() died and we trapped the error. We should restore
3723          * the old PL_restartjmpenv and PL_restartop values, as they are
3724          * used only in the case where the code was actually run.
3725          * The assert validates that we will still execute the PL_restartop.
3726          */
3727         assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3728         PL_restartjmpenv = restartjmpenv;
3729         PL_restartop = restartop;
3730         break;
3731     default:
3732         JMPENV_POP;
3733         JMPENV_JUMP(ret);
3734         NOT_REACHED; /* NOTREACHED */
3735     }
3736     JMPENV_POP;
3737     return ret;
3738 }
3739
3740 /* Compile a require/do or an eval ''.
3741  *
3742  * outside is the lexically enclosing CV (if any) that invoked us.
3743  * seq     is the current COP scope value.
3744  * hh      is the saved hints hash, if any.
3745  *
3746  * Returns a bool indicating whether the compile was successful; if so,
3747  * PL_eval_start contains the first op of the compiled code; otherwise,
3748  * pushes undef.
3749  *
3750  * This function is called from two places: pp_require and pp_entereval.
3751  * These can be distinguished by whether PL_op is entereval.
3752  */
3753
3754 STATIC bool
3755 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3756 {
3757     dSP;
3758     OP * const saveop = PL_op;
3759     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3760     COP * const oldcurcop = PL_curcop;
3761     bool in_require = (saveop->op_type == OP_REQUIRE);
3762     int yystatus;
3763     CV *evalcv;
3764
3765     PL_in_eval = (in_require
3766                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3767                   : (EVAL_INEVAL |
3768                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3769                             ? EVAL_RE_REPARSING : 0)));
3770
3771     PUSHMARK(SP);
3772
3773     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3774     CvEVAL_on(evalcv);
3775     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3776     CX_CUR()->blk_eval.cv = evalcv;
3777     CX_CUR()->blk_gimme = gimme;
3778
3779     CvOUTSIDE_SEQ(evalcv) = seq;
3780     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3781
3782     /* set up a scratch pad */
3783
3784     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3785     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3786
3787
3788     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3789
3790     /* make sure we compile in the right package */
3791
3792     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3793         SAVEGENERICSV(PL_curstash);
3794         PL_curstash = (HV *)CopSTASH(PL_curcop);
3795         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3796         else {
3797             SvREFCNT_inc_simple_void(PL_curstash);
3798             save_item(PL_curstname);
3799             sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3800         }
3801     }
3802     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3803     SAVESPTR(PL_beginav);
3804     PL_beginav = newAV();
3805     SAVEFREESV(PL_beginav);
3806     SAVESPTR(PL_unitcheckav);
3807     PL_unitcheckav = newAV();
3808     SAVEFREESV(PL_unitcheckav);
3809
3810
3811     ENTER_with_name("evalcomp");
3812     SAVESPTR(PL_compcv);
3813     PL_compcv = evalcv;
3814
3815     /* try to compile it */
3816
3817     PL_eval_root = NULL;
3818     PL_curcop = &PL_compiling;
3819     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3820         PL_in_eval |= EVAL_KEEPERR;
3821     else
3822         CLEAR_ERRSV();
3823
3824     SAVEHINTS();
3825     if (clear_hints) {
3826         PL_hints = HINTS_DEFAULT;
3827         PL_prevailing_version = 0;
3828         hv_clear(GvHV(PL_hintgv));
3829         CLEARFEATUREBITS();
3830     }
3831     else {
3832         PL_hints = saveop->op_private & OPpEVAL_COPHH
3833                      ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3834
3835         /* making 'use re eval' not be in scope when compiling the
3836          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3837          * infinite recursion when S_has_runtime_code() gives a false
3838          * positive: the second time round, HINT_RE_EVAL isn't set so we
3839          * don't bother calling S_has_runtime_code() */
3840         if (PL_in_eval & EVAL_RE_REPARSING)
3841             PL_hints &= ~HINT_RE_EVAL;
3842
3843         if (hh) {
3844             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3845             SvREFCNT_dec(GvHV(PL_hintgv));
3846             GvHV(PL_hintgv) = hh;
3847             FETCHFEATUREBITSHH(hh);
3848         }
3849     }
3850     SAVECOMPILEWARNINGS();
3851     if (clear_hints) {
3852         if (PL_dowarn & G_WARN_ALL_ON)
3853             PL_compiling.cop_warnings = pWARN_ALL ;
3854         else if (PL_dowarn & G_WARN_ALL_OFF)
3855             PL_compiling.cop_warnings = pWARN_NONE ;
3856         else
3857             PL_compiling.cop_warnings = pWARN_STD ;
3858     }
3859     else {
3860         PL_compiling.cop_warnings =
3861             DUP_WARNINGS(oldcurcop->cop_warnings);
3862         cophh_free(CopHINTHASH_get(&PL_compiling));
3863         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3864             /* The label, if present, is the first entry on the chain. So rather
3865                than writing a blank label in front of it (which involves an
3866                allocation), just use the next entry in the chain.  */
3867             PL_compiling.cop_hints_hash
3868                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3869             /* Check the assumption that this removed the label.  */
3870             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3871         }
3872         else
3873             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3874     }
3875
3876     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3877
3878     /* we should never be CATCH_GET true here, as our immediate callers should
3879      * always handle that case. */
3880     assert(!CATCH_GET);
3881     /* compile the code */
3882
3883
3884     yystatus = (!in_require)
3885                ? S_try_yyparse(aTHX_ GRAMPROG, saveop)
3886                : yyparse(GRAMPROG);
3887
3888     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3889         PERL_CONTEXT *cx;
3890         SV *errsv;
3891
3892         PL_op = saveop;
3893         if (yystatus != 3) {
3894             /* note that if yystatus == 3, then the require/eval died during
3895              * compilation, so the EVAL CX block has already been popped, and
3896              * various vars restored. This block applies similar steps after
3897              * the other "failed to compile" cases in yyparse, eg, where
3898              * yystatus=1, "failed, but did not die". */
3899
3900             if (!in_require)
3901                 invoke_exception_hook(ERRSV,FALSE);
3902             if (PL_eval_root) {
3903                 op_free(PL_eval_root);
3904                 PL_eval_root = NULL;
3905             }
3906             SP = PL_stack_base + POPMARK;       /* pop original mark */
3907             cx = CX_CUR();
3908             assert(CxTYPE(cx) == CXt_EVAL);
3909             /* If we are in an eval we need to make sure that $SIG{__DIE__}
3910              * handler is invoked so we simulate that part of the
3911              * Perl_die_unwind() process. In a require we will croak
3912              * so it will happen there. */
3913             /* pop the CXt_EVAL, and if was a require, croak */
3914             S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3915         }
3916
3917         /* die_unwind() re-croaks when in require, having popped the
3918          * require EVAL context. So we should never catch a require
3919          * exception here */
3920         assert(!in_require);
3921
3922         errsv = ERRSV;
3923         if (!*(SvPV_nolen_const(errsv)))
3924             sv_setpvs(errsv, "Compilation error");
3925
3926
3927         if (gimme != G_LIST) PUSHs(&PL_sv_undef);
3928         PUTBACK;
3929         return FALSE;
3930     }
3931
3932     /* Compilation successful. Now clean up */
3933
3934     LEAVE_with_name("evalcomp");
3935
3936     CopLINE_set(&PL_compiling, 0);
3937     SAVEFREEOP(PL_eval_root);
3938     cv_forget_slab(evalcv);
3939
3940     DEBUG_x(dump_eval());
3941
3942     /* Register with debugger: */
3943     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3944         CV * const cv = get_cvs("DB::postponed", 0);
3945         if (cv) {
3946             dSP;
3947             PUSHMARK(SP);
3948             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3949             PUTBACK;
3950             call_sv(MUTABLE_SV(cv), G_DISCARD);
3951         }
3952     }
3953
3954     if (PL_unitcheckav && av_count(PL_unitcheckav)>0) {
3955         OP *es = PL_eval_start;
3956         /* TODO: are we sure we shouldn't do S_try_run_unitcheck()
3957         * when `in_require` is true? */
3958         if (in_require) {
3959             call_list(PL_scopestack_ix, PL_unitcheckav);
3960         }
3961         else if (S_try_run_unitcheck(aTHX_ saveop)) {
3962             /* there was an error! */
3963
3964             /* Restore PL_OP */
3965             PL_op = saveop;
3966
3967             SV *errsv = ERRSV;
3968             if (!*(SvPV_nolen_const(errsv))) {
3969                 /* This happens when using:
3970                  * eval qq# UNITCHECK { die "\x00"; } #;
3971                  */
3972                 sv_setpvs(errsv, "Unit check error");
3973             }
3974
3975             if (gimme != G_LIST) PUSHs(&PL_sv_undef);
3976             PUTBACK;
3977             return FALSE;
3978         }
3979         PL_eval_start = es;
3980     }
3981
3982     CvDEPTH(evalcv) = 1;
3983     SP = PL_stack_base + POPMARK;               /* pop original mark */
3984     PL_op = saveop;                     /* The caller may need it. */
3985     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3986
3987     PUTBACK;
3988     return TRUE;
3989 }
3990
3991 /* Return NULL if the file doesn't exist or isn't a file;
3992  * else return PerlIO_openn().
3993  */
3994
3995 STATIC PerlIO *
3996 S_check_type_and_open(pTHX_ SV *name)
3997 {
3998     Stat_t st;
3999     STRLEN len;
4000     PerlIO * retio;
4001     const char *p = SvPV_const(name, len);
4002     int st_rc;
4003
4004     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
4005
4006     /* checking here captures a reasonable error message when
4007      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
4008      * user gets a confusing message about looking for the .pmc file
4009      * rather than for the .pm file so do the check in S_doopen_pm when
4010      * PMC is on instead of here. S_doopen_pm calls this func.
4011      * This check prevents a \0 in @INC causing problems.
4012      */
4013 #ifdef PERL_DISABLE_PMC
4014     if (!IS_SAFE_PATHNAME(p, len, "require"))
4015         return NULL;
4016 #endif
4017
4018     /* on Win32 stat is expensive (it does an open() and close() twice and
4019        a couple other IO calls), the open will fail with a dir on its own with
4020        errno EACCES, so only do a stat to separate a dir from a real EACCES
4021        caused by user perms */
4022 #ifndef WIN32
4023     st_rc = PerlLIO_stat(p, &st);
4024
4025     if (st_rc < 0)
4026         return NULL;
4027     else {
4028         int eno;
4029         if(S_ISBLK(st.st_mode)) {
4030             eno = EINVAL;
4031             goto not_file;
4032         }
4033         else if(S_ISDIR(st.st_mode)) {
4034             eno = EISDIR;
4035             not_file:
4036             errno = eno;
4037             return NULL;
4038         }
4039     }
4040 #endif
4041
4042     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
4043 #ifdef WIN32
4044     /* EACCES stops the INC search early in pp_require to implement
4045        feature RT #113422 */
4046     if(!retio && errno == EACCES) { /* exists but probably a directory */
4047         int eno;
4048         st_rc = PerlLIO_stat(p, &st);
4049         if (st_rc >= 0) {
4050             if(S_ISDIR(st.st_mode))
4051                 eno = EISDIR;
4052             else if(S_ISBLK(st.st_mode))
4053                 eno = EINVAL;
4054             else
4055                 eno = EACCES;
4056             errno = eno;
4057         }
4058     }
4059 #endif
4060     return retio;
4061 }
4062
4063 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
4064  * but first check for bad names (\0) and non-files.
4065  * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
4066  * try loading Foo.pmc first.
4067  */
4068 #ifndef PERL_DISABLE_PMC
4069 STATIC PerlIO *
4070 S_doopen_pm(pTHX_ SV *name)
4071 {
4072     STRLEN namelen;
4073     const char *p = SvPV_const(name, namelen);
4074
4075     PERL_ARGS_ASSERT_DOOPEN_PM;
4076
4077     /* check the name before trying for the .pmc name to avoid the
4078      * warning referring to the .pmc which the user probably doesn't
4079      * know or care about
4080      */
4081     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
4082         return NULL;
4083
4084     if (memENDPs(p, namelen, ".pm")) {
4085         SV *const pmcsv = sv_newmortal();
4086         PerlIO * pmcio;
4087
4088         SvSetSV_nosteal(pmcsv,name);
4089         sv_catpvs(pmcsv, "c");
4090
4091         pmcio = check_type_and_open(pmcsv);
4092         if (pmcio)
4093             return pmcio;
4094     }
4095     return check_type_and_open(name);
4096 }
4097 #else
4098 #  define doopen_pm(name) check_type_and_open(name)
4099 #endif /* !PERL_DISABLE_PMC */
4100
4101 /* require doesn't search in @INC for absolute names, or when the name is
4102    explicitly relative the current directory: i.e. ./, ../ */
4103 PERL_STATIC_INLINE bool
4104 S_path_is_searchable(const char *name)
4105 {
4106     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
4107
4108     if (PERL_FILE_IS_ABSOLUTE(name)
4109 #ifdef WIN32
4110         || (*name == '.' && ((name[1] == '/' ||
4111                              (name[1] == '.' && name[2] == '/'))
4112                          || (name[1] == '\\' ||
4113                              ( name[1] == '.' && name[2] == '\\')))
4114             )
4115 #else
4116         || (*name == '.' && (name[1] == '/' ||
4117                              (name[1] == '.' && name[2] == '/')))
4118 #endif
4119          )
4120     {
4121         return FALSE;
4122     }
4123     else
4124         return TRUE;
4125 }
4126
4127
4128 /* implement 'require 5.010001' */
4129
4130 static OP *
4131 S_require_version(pTHX_ SV *sv)
4132 {
4133     dSP;
4134
4135     sv = sv_2mortal(new_version(sv));
4136     if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
4137         upg_version(PL_patchlevel, TRUE);
4138     if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
4139         if ( vcmp(sv,PL_patchlevel) <= 0 )
4140             DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
4141                 SVfARG(sv_2mortal(vnormal(sv))),
4142                 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4143             );
4144     }
4145     else {
4146         if ( vcmp(sv,PL_patchlevel) > 0 ) {
4147             I32 first = 0;
4148             AV *lav;
4149             SV * const req = SvRV(sv);
4150             SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
4151
4152             /* get the left hand term */
4153             lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
4154
4155             first  = SvIV(*av_fetch(lav,0,0));
4156             if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
4157                 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
4158                 || av_count(lav) > 2             /* FP with > 3 digits */
4159                 || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
4160                ) {
4161                 DIE(aTHX_ "Perl %" SVf " required--this is only "
4162                     "%" SVf ", stopped",
4163                     SVfARG(sv_2mortal(vnormal(req))),
4164                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4165                 );
4166             }
4167             else { /* probably 'use 5.10' or 'use 5.8' */
4168                 SV *hintsv;
4169                 I32 second = 0;
4170
4171                 if (av_count(lav) > 1)
4172                     second = SvIV(*av_fetch(lav,1,0));
4173
4174                 second /= second >= 600  ? 100 : 10;
4175                 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
4176                                        (int)first, (int)second);
4177                 upg_version(hintsv, TRUE);
4178
4179                 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
4180                     "--this is only %" SVf ", stopped",
4181                     SVfARG(sv_2mortal(vnormal(req))),
4182                     SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
4183                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4184                 );
4185             }
4186         }
4187     }
4188
4189     RETPUSHYES;
4190 }
4191
4192 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
4193  * The first form will have already been converted at compile time to
4194  * the second form */
4195
4196 static OP *
4197 S_require_file(pTHX_ SV *sv)
4198 {
4199     dSP;
4200
4201     PERL_CONTEXT *cx;
4202     const char *name;
4203     STRLEN len;
4204     char * unixname;
4205     STRLEN unixlen;
4206 #ifdef VMS
4207     int vms_unixname = 0;
4208     char *unixdir;
4209 #endif
4210     /* tryname is the actual pathname (with @INC prefix) which was loaded.
4211      * It's stored as a value in %INC, and used for error messages */
4212     const char *tryname = NULL;
4213     SV *namesv = NULL; /* SV equivalent of tryname */
4214     const U8 gimme = GIMME_V;
4215     int filter_has_file = 0;
4216     PerlIO *tryrsfp = NULL;
4217     SV *filter_cache = NULL;
4218     SV *filter_state = NULL;
4219     SV *filter_sub = NULL;
4220     SV *hook_sv = NULL;
4221     OP *op;
4222     int saved_errno;
4223     bool path_searchable;
4224     I32 old_savestack_ix;
4225     const bool op_is_require = PL_op->op_type == OP_REQUIRE;
4226     const char *const op_name = op_is_require ? "require" : "do";
4227     SV ** svp_cached = NULL;
4228
4229     assert(op_is_require || PL_op->op_type == OP_DOFILE);
4230
4231     if (!SvOK(sv))
4232         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4233     name = SvPV_nomg_const(sv, len);
4234     if (!(name && len > 0 && *name))
4235         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4236
4237     if (
4238         PL_hook__require__before
4239         && SvROK(PL_hook__require__before)
4240         && SvTYPE(SvRV(PL_hook__require__before)) == SVt_PVCV
4241     ) {
4242         SV* name_sv = sv_mortalcopy(sv);
4243         SV *post_hook__require__before_sv = NULL;
4244
4245         ENTER_with_name("call_PRE_REQUIRE");
4246         SAVETMPS;
4247         EXTEND(SP, 1);
4248         PUSHMARK(SP);
4249         PUSHs(name_sv); /* always use the object for method calls */
4250         PUTBACK;
4251         int count = call_sv(PL_hook__require__before, G_SCALAR);
4252         SPAGAIN;
4253         if (count && SvOK(*SP) && SvROK(*SP) && SvTYPE(SvRV(*SP)) == SVt_PVCV)
4254             post_hook__require__before_sv = SvREFCNT_inc_simple_NN(*SP);
4255         if (!sv_streq(name_sv,sv)) {
4256             /* they modified the name argument, so do some sleight of hand */
4257             name = SvPV_nomg_const(name_sv, len);
4258             if (!(name && len > 0 && *name))
4259                 DIE(aTHX_ "Missing or undefined argument to %s via %%{^HOOK}{require__before}",
4260                         op_name);
4261             sv = SvREFCNT_inc_simple_NN(name_sv);
4262         }
4263         FREETMPS;
4264         LEAVE_with_name("call_PRE_REQUIRE");
4265         if (post_hook__require__before_sv) {
4266             MORTALDESTRUCTOR_SV(post_hook__require__before_sv, newSVsv(sv));
4267         }
4268     }
4269     if (
4270         PL_hook__require__after
4271         && SvROK(PL_hook__require__after)
4272         && SvTYPE(SvRV(PL_hook__require__after)) == SVt_PVCV
4273     ) {
4274         MORTALDESTRUCTOR_SV(PL_hook__require__after, newSVsv(sv));
4275     }
4276
4277 #ifndef VMS
4278         /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
4279         if (op_is_require) {
4280                 /* can optimize to only perform one single lookup */
4281                 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
4282                 if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES;
4283         }
4284 #endif
4285
4286     if (!IS_SAFE_PATHNAME(name, len, op_name)) {
4287         if (!op_is_require) {
4288             CLEAR_ERRSV();
4289             RETPUSHUNDEF;
4290         }
4291         DIE(aTHX_ "Can't locate %s:   %s",
4292             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
4293                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
4294             Strerror(ENOENT));
4295     }
4296     TAINT_PROPER(op_name);
4297
4298     path_searchable = path_is_searchable(name);
4299
4300 #ifdef VMS
4301     /* The key in the %ENV hash is in the syntax of file passed as the argument
4302      * usually this is in UNIX format, but sometimes in VMS format, which
4303      * can result in a module being pulled in more than once.
4304      * To prevent this, the key must be stored in UNIX format if the VMS
4305      * name can be translated to UNIX.
4306      */
4307
4308     if ((unixname =
4309           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4310          != NULL) {
4311         unixlen = strlen(unixname);
4312         vms_unixname = 1;
4313     }
4314     else
4315 #endif
4316     {
4317         /* if not VMS or VMS name can not be translated to UNIX, pass it
4318          * through.
4319          */
4320         unixname = (char *) name;
4321         unixlen = len;
4322     }
4323     if (op_is_require) {
4324         /* reuse the previous hv_fetch result if possible */
4325         SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4326         if ( svp ) {
4327             /* we already did a get magic if this was cached */
4328             if (!svp_cached)
4329                 SvGETMAGIC(*svp);
4330             if (SvOK(*svp))
4331                 RETPUSHYES;
4332             else
4333                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
4334                             "Compilation failed in require", unixname);
4335         }
4336
4337         /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
4338         if (PL_op->op_flags & OPf_KIDS) {
4339             SVOP * const kid = cSVOPx(cUNOP->op_first);
4340
4341             if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4342                 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
4343                  * doesn't map to a naughty pathname like /Foo/Bar.pm.
4344                  * Note that the parser will normally detect such errors
4345                  * at compile time before we reach here, but
4346                  * Perl_load_module() can fake up an identical optree
4347                  * without going near the parser, and being able to put
4348                  * anything as the bareword. So we include a duplicate set
4349                  * of checks here at runtime.
4350                  */
4351                 const STRLEN package_len = len - 3;
4352                 const char slashdot[2] = {'/', '.'};
4353 #ifdef DOSISH
4354                 const char backslashdot[2] = {'\\', '.'};
4355 #endif
4356
4357                 /* Disallow *purported* barewords that map to absolute
4358                    filenames, filenames relative to the current or parent
4359                    directory, or (*nix) hidden filenames.  Also sanity check
4360                    that the generated filename ends .pm  */
4361                 if (!path_searchable || len < 3 || name[0] == '.'
4362                     || !memEQs(name + package_len, len - package_len, ".pm"))
4363                     DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
4364                 if (memchr(name, 0, package_len)) {
4365                     /* diag_listed_as: Bareword in require contains "%s" */
4366                     DIE(aTHX_ "Bareword in require contains \"\\0\"");
4367                 }
4368                 if (ninstr(name, name + package_len, slashdot,
4369                            slashdot + sizeof(slashdot))) {
4370                     /* diag_listed_as: Bareword in require contains "%s" */
4371                     DIE(aTHX_ "Bareword in require contains \"/.\"");
4372                 }
4373 #ifdef DOSISH
4374                 if (ninstr(name, name + package_len, backslashdot,
4375                            backslashdot + sizeof(backslashdot))) {
4376                     /* diag_listed_as: Bareword in require contains "%s" */
4377                     DIE(aTHX_ "Bareword in require contains \"\\.\"");
4378                 }
4379 #endif
4380             }
4381         }
4382     }
4383
4384     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
4385
4386     /* Try to locate and open a file, possibly using @INC  */
4387
4388     /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
4389      * the file directly rather than via @INC ... */
4390     if (!path_searchable) {
4391         /* At this point, name is SvPVX(sv)  */
4392         tryname = name;
4393         tryrsfp = doopen_pm(sv);
4394     }
4395
4396     /* ... but if we fail, still search @INC for code references;
4397      * these are applied even on non-searchable paths (except
4398      * if we got EACESS).
4399      *
4400      * For searchable paths, just search @INC normally
4401      */
4402     AV *inc_checked = (AV*)sv_2mortal((SV*)newAV());
4403     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
4404         SSize_t inc_idx;
4405 #ifdef VMS
4406         if (vms_unixname)
4407 #endif
4408         {
4409             AV *incdir_av = (AV*)sv_2mortal((SV*)newAV());
4410             SV *nsv = sv; /* non const copy we can change if necessary */
4411             namesv = newSV_type(SVt_PV);
4412             AV *inc_ar = GvAVn(PL_incgv);
4413             SSize_t incdir_continue_inc_idx = -1;
4414
4415             for (
4416                 inc_idx = 0;
4417                 (AvFILL(incdir_av)>=0 /* we have INCDIR items pending */
4418                     || inc_idx <= AvFILL(inc_ar));  /* @INC entries remain */
4419                 inc_idx++
4420             ) {
4421                 SV *dirsv;
4422
4423                 /* do we have any pending INCDIR items? */
4424                 if (AvFILL(incdir_av)>=0) {
4425                     /* yep, shift it out */
4426                     dirsv = av_shift(incdir_av);
4427                     if (AvFILL(incdir_av)<0) {
4428                         /* incdir is now empty, continue from where
4429                          * we left off after we process this entry  */
4430                         inc_idx = incdir_continue_inc_idx;
4431                     }
4432                 } else {
4433                     dirsv = *av_fetch(inc_ar, inc_idx, TRUE);
4434                 }
4435
4436                 if (SvGMAGICAL(dirsv)) {
4437                     SvGETMAGIC(dirsv);
4438                     dirsv = newSVsv_nomg(dirsv);
4439                 } else {
4440                     /* on the other hand, since we aren't copying we do need
4441                      * to increment */
4442                     SvREFCNT_inc(dirsv);
4443                 }
4444                 if (!SvOK(dirsv))
4445                     continue;
4446
4447                 av_push(inc_checked, dirsv);
4448
4449                 if (SvROK(dirsv)) {
4450                     int count;
4451                     SV **svp;
4452                     SV *loader = dirsv;
4453                     UV diruv = PTR2UV(SvRV(dirsv));
4454
4455                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
4456                         && !SvOBJECT(SvRV(loader)))
4457                     {
4458                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4459                         if (SvGMAGICAL(loader)) {
4460                             SvGETMAGIC(loader);
4461                             SV *l = sv_newmortal();
4462                             sv_setsv_nomg(l, loader);
4463                             loader = l;
4464                         }
4465                     }
4466
4467                     if (SvPADTMP(nsv)) {
4468                         nsv = sv_newmortal();
4469                         SvSetSV_nosteal(nsv,sv);
4470                     }
4471
4472                     const char *method = NULL;
4473                     bool is_incdir = FALSE;
4474                     SV * inc_idx_sv = save_scalar(PL_incgv);
4475                     sv_setiv(inc_idx_sv,inc_idx);
4476                     if (sv_isobject(loader)) {
4477                         /* if it is an object and it has an INC method, then
4478                          * call the method.
4479                          */
4480                         HV *pkg = SvSTASH(SvRV(loader));
4481                         GV * gv = gv_fetchmethod_pvn_flags(pkg, "INC", 3, GV_AUTOLOAD);
4482                         if (gv && isGV(gv)) {
4483                             method = "INC";
4484                         } else {
4485                             /* no point to autoload here, it would have been found above */
4486                             gv = gv_fetchmethod_pvn_flags(pkg, "INCDIR", 6, 0);
4487                             if (gv && isGV(gv)) {
4488                                 method = "INCDIR";
4489                                 is_incdir = TRUE;
4490                             }
4491                         }
4492                         /* But if we have no method, check if this is a
4493                          * coderef, if it is then we treat it as an
4494                          * unblessed coderef would be treated: we
4495                          * execute it. If it is some other and it is in
4496                          * an array ref wrapper, then really we don't
4497                          * know what to do with it, (why use the
4498                          * wrapper?) and we throw an exception to help
4499                          * debug. If it is not in a wrapper assume it
4500                          * has an overload and treat it as a string.
4501                          * Maybe in the future we can detect if it does
4502                          * have overloading and throw an error if not.
4503                          */
4504                         if (!method) {
4505                             if (SvTYPE(SvRV(loader)) != SVt_PVCV) {
4506                                 if (amagic_applies(loader,string_amg,AMGf_unary))
4507                                     goto treat_as_string;
4508                                 else {
4509                                     croak("Can't locate object method \"INC\", nor"
4510                                           " \"INCDIR\" nor string overload via"
4511                                           " package %" HvNAMEf_QUOTEDPREFIX " %s"
4512                                           " in @INC", pkg,
4513                                           dirsv == loader
4514                                           ? "in object hook"
4515                                           : "in object in ARRAY hook"
4516                                     );
4517                                 }
4518                             }
4519                         }
4520                     }
4521
4522                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4523                                    diruv, name);
4524                     tryname = SvPVX_const(namesv);
4525                     tryrsfp = NULL;
4526
4527                     ENTER_with_name("call_INC_hook");
4528                     SAVETMPS;
4529                     EXTEND(SP, 2 + ((method && (loader != dirsv)) ? 1 : 0));
4530                     PUSHMARK(SP);
4531                     PUSHs(method ? loader : dirsv); /* always use the object for method calls */
4532                     PUSHs(nsv);
4533                     if (method && (loader != dirsv)) /* add the args array for method calls */
4534                         PUSHs(dirsv);
4535                     PUTBACK;
4536                     if (method) {
4537                         count = call_method(method, G_LIST|G_EVAL);
4538                     } else {
4539                         count = call_sv(loader, G_LIST|G_EVAL);
4540                     }
4541                     SPAGAIN;
4542
4543                     if (count > 0) {
4544                         int i = 0;
4545                         SV *arg;
4546
4547                         SP -= count - 1;
4548
4549                         if (is_incdir) {
4550                             /* push the stringified returned items into the
4551                              * incdir_av array for processing immediately
4552                              * afterwards. we deliberately stringify or copy
4553                              * "special" arguments, so that overload logic for
4554                              * instance applies, but so that the end result is
4555                              * stable. We speficially do *not* support returning
4556                              * coderefs from an INCDIR call. */
4557                             while (count-->0) {
4558                                 arg = SP[i++];
4559                                 SvGETMAGIC(arg);
4560                                 if (!SvOK(arg))
4561                                     continue;
4562                                 if (SvROK(arg)) {
4563                                     STRLEN l;
4564                                     char *pv = SvPV(arg,l);
4565                                     arg = newSVpvn(pv,l);
4566                                 }
4567                                 else if (SvGMAGICAL(arg)) {
4568                                     arg = newSVsv_nomg(arg);
4569                                 }
4570                                 else {
4571                                     SvREFCNT_inc(arg);
4572                                 }
4573                                 av_push(incdir_av, arg);
4574                             }
4575                             /* We copy $INC into incdir_continue_inc_idx
4576                              * so that when we finish processing the items
4577                              * we just inserted into incdir_av we can continue
4578                              * as though we had just finished executing the INCDIR
4579                              * hook. We honour $INC here just like we would for
4580                              * an INC hook, the hook might have rewritten @INC
4581                              * at the same time as returning something to us.
4582                              */
4583                             inc_idx_sv = GvSVn(PL_incgv);
4584                             incdir_continue_inc_idx = SvOK(inc_idx_sv)
4585                                                       ? SvIV(inc_idx_sv) : -1;
4586
4587                             goto done_hook;
4588                         }
4589
4590                         arg = SP[i++];
4591
4592                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4593                             && !isGV_with_GP(SvRV(arg))) {
4594                             filter_cache = SvRV(arg);
4595
4596                             if (i < count) {
4597                                 arg = SP[i++];
4598                             }
4599                         }
4600
4601                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4602                             arg = SvRV(arg);
4603                         }
4604
4605                         if (isGV_with_GP(arg)) {
4606                             IO * const io = GvIO((const GV *)arg);
4607
4608                             ++filter_has_file;
4609
4610                             if (io) {
4611                                 tryrsfp = IoIFP(io);
4612                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4613                                     PerlIO_close(IoOFP(io));
4614                                 }
4615                                 IoIFP(io) = NULL;
4616                                 IoOFP(io) = NULL;
4617                             }
4618
4619                             if (i < count) {
4620                                 arg = SP[i++];
4621                             }
4622                         }
4623
4624                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4625                             filter_sub = arg;
4626                             SvREFCNT_inc_simple_void_NN(filter_sub);
4627
4628                             if (i < count) {
4629                                 filter_state = SP[i];
4630                                 SvREFCNT_inc_simple_void(filter_state);
4631                             }
4632                         }
4633
4634                         if (!tryrsfp && (filter_cache || filter_sub)) {
4635                             tryrsfp = PerlIO_open(BIT_BUCKET,
4636                                                   PERL_SCRIPT_MODE);
4637                         }
4638                         done_hook:
4639                         SP--;
4640                     } else {
4641                         SV *errsv= ERRSV;
4642                         if (SvTRUE(errsv) && !SvROK(errsv)) {
4643                             STRLEN l;
4644                             char *pv= SvPV(errsv,l);
4645                             /* Heuristic to tell if this error message
4646                              * includes the standard line number info:
4647                              * check if the line ends in digit dot newline.
4648                              * If it does then we add some extra info so
4649                              * its obvious this is coming from a hook.
4650                              * If it is a user generated error we try to
4651                              * leave it alone. l>12 is to ensure the
4652                              * other checks are in string, but also
4653                              * accounts for "at ... line 1.\n" to a
4654                              * certain extent. Really we should check
4655                              * further, but this is good enough for back
4656                              * compat I think.
4657                              */
4658                             if (l>=12 && pv[l-1] == '\n' && pv[l-2] == '.' && isDIGIT(pv[l-3]))
4659                                 sv_catpvf(errsv, "%s %s hook died--halting @INC search",
4660                                           method ? method : "INC",
4661                                           method ? "method" : "sub");
4662                             croak_sv(errsv);
4663                         }
4664                     }
4665
4666                     /* FREETMPS may free our filter_cache */
4667                     SvREFCNT_inc_simple_void(filter_cache);
4668
4669                     /*
4670                      Let the hook override which @INC entry we visit
4671                      next by setting $INC to a different value than it
4672                      was before we called the hook. If they have
4673                      completely rewritten the array they might want us
4674                      to start traversing from the beginning, which is
4675                      represented by -1. We use undef as an equivalent of
4676                      -1. This can't be used as a way to call a hook
4677                      twice, as we still dedupe.
4678                      We have to do this before we LEAVE, as we localized
4679                      $INC before we called the hook.
4680                     */
4681                     inc_idx_sv = GvSVn(PL_incgv);
4682                     inc_idx = SvOK(inc_idx_sv) ? SvIV(inc_idx_sv) : -1;
4683
4684                     PUTBACK;
4685                     FREETMPS;
4686                     LEAVE_with_name("call_INC_hook");
4687
4688                     /*
4689                      It is possible that @INC has been replaced and that inc_ar
4690                      now points at a freed AV. So we have to refresh it from
4691                      the GV to be sure.
4692                     */
4693                     inc_ar = GvAVn(PL_incgv);
4694
4695                     /* Now re-mortalize it. */
4696                     sv_2mortal(filter_cache);
4697
4698                     /* Adjust file name if the hook has set an %INC entry.
4699                        This needs to happen after the FREETMPS above.  */
4700                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4701                     /* we have to make sure that the value is not undef
4702                      * or the empty string, if it is then we should not
4703                      * set tryname to it as this will break error messages.
4704                      *
4705                      * This might happen if an @INC hook evals the module
4706                      * which was required in the first place and which
4707                      * triggered the @INC hook, and that eval dies.
4708                      * See https://github.com/Perl/perl5/issues/20535
4709                      */
4710                     if (svp && SvOK(*svp)) {
4711                         STRLEN len;
4712                         const char *tmp_pv = SvPV_const(*svp,len);
4713                         /* we also guard against the deliberate empty string.
4714                          * We do not guard against '0', if people want to set their
4715                          * file name to 0 that is up to them. */
4716                         if (len)
4717                             tryname = tmp_pv;
4718                     }
4719
4720                     if (tryrsfp) {
4721                         hook_sv = dirsv;
4722                         break;
4723                     }
4724
4725                     filter_has_file = 0;
4726                     filter_cache = NULL;
4727                     if (filter_state) {
4728                         SvREFCNT_dec_NN(filter_state);
4729                         filter_state = NULL;
4730                     }
4731                     if (filter_sub) {
4732                         SvREFCNT_dec_NN(filter_sub);
4733                         filter_sub = NULL;
4734                     }
4735                 }
4736                 else
4737                     treat_as_string:
4738                     if (path_searchable) {
4739                     /* match against a plain @INC element (non-searchable
4740                      * paths are only matched against refs in @INC) */
4741                     const char *dir;
4742                     STRLEN dirlen;
4743                     if (SvOK(dirsv)) {
4744                         dir = SvPV_nomg_const(dirsv, dirlen);
4745                     } else {
4746                         dir = "";
4747                         dirlen = 0;
4748                     }
4749
4750                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4751                         continue;
4752 #ifdef VMS
4753                     if ((unixdir =
4754                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4755                          == NULL)
4756                         continue;
4757                     sv_setpv(namesv, unixdir);
4758                     sv_catpv(namesv, unixname);
4759 #else
4760                     /* The equivalent of
4761                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4762                        but without the need to parse the format string, or
4763                        call strlen on either pointer, and with the correct
4764                        allocation up front.  */
4765                     {
4766                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4767
4768                         memcpy(tmp, dir, dirlen);
4769                         tmp +=dirlen;
4770
4771                         /* Avoid '<dir>//<file>' */
4772                         if (!dirlen || *(tmp-1) != '/') {
4773                             *tmp++ = '/';
4774                         } else {
4775                             /* So SvCUR_set reports the correct length below */
4776                             dirlen--;
4777                         }
4778
4779                         /* name came from an SV, so it will have a '\0' at the
4780                            end that we can copy as part of this memcpy().  */
4781                         memcpy(tmp, name, len + 1);
4782
4783                         SvCUR_set(namesv, dirlen + len + 1);
4784                         SvPOK_on(namesv);
4785                     }
4786 #endif
4787                     TAINT_PROPER(op_name);
4788                     tryname = SvPVX_const(namesv);
4789                     tryrsfp = doopen_pm(namesv);
4790                     if (tryrsfp) {
4791                         if (tryname[0] == '.' && tryname[1] == '/') {
4792                             ++tryname;
4793                             while (*++tryname == '/') {}
4794                         }
4795                         break;
4796                     }
4797                     else if (errno == EMFILE || errno == EACCES) {
4798                         /* no point in trying other paths if out of handles;
4799                          * on the other hand, if we couldn't open one of the
4800                          * files, then going on with the search could lead to
4801                          * unexpected results; see perl #113422
4802                          */
4803                         break;
4804                     }
4805                 }
4806             }
4807         }
4808     }
4809
4810     /* at this point we've ether opened a file (tryrsfp) or set errno */
4811
4812     saved_errno = errno; /* sv_2mortal can realloc things */
4813     sv_2mortal(namesv);
4814     if (!tryrsfp) {
4815         /* we failed; croak if require() or return undef if do() */
4816         if (op_is_require) {
4817             if(saved_errno == EMFILE || saved_errno == EACCES) {
4818                 /* diag_listed_as: Can't locate %s */
4819                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4820                     name, tryname, Strerror(saved_errno));
4821             } else {
4822                 if (path_searchable) {          /* did we lookup @INC? */
4823                     SSize_t i;
4824                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4825                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4826                     for (i = 0; i <= AvFILL(inc_checked); i++) {
4827                         SV **svp= av_fetch(inc_checked, i, TRUE);
4828                         if (!svp || !*svp) continue;
4829                         sv_catpvs(inc, " ");
4830                         sv_catsv(inc, *svp);
4831                     }
4832                     if (memENDPs(name, len, ".pm")) {
4833                         const char *e = name + len - (sizeof(".pm") - 1);
4834                         const char *c;
4835                         bool utf8 = cBOOL(SvUTF8(sv));
4836
4837                         /* if the filename, when converted from "Foo/Bar.pm"
4838                          * form back to Foo::Bar form, makes a valid
4839                          * package name (i.e. parseable by C<require
4840                          * Foo::Bar>), then emit a hint.
4841                          *
4842                          * this loop is modelled after the one in
4843                          S_parse_ident */
4844                         c = name;
4845                         while (c < e) {
4846                             if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4847                                 c += UTF8SKIP(c);
4848                                 while (c < e && isIDCONT_utf8_safe(
4849                                             (const U8*) c, (const U8*) e))
4850                                     c += UTF8SKIP(c);
4851                             }
4852                             else if (isWORDCHAR_A(*c)) {
4853                                 while (c < e && isWORDCHAR_A(*c))
4854                                     c++;
4855                             }
4856                             else if (*c == '/')
4857                                 c++;
4858                             else
4859                                 break;
4860                         }
4861
4862                         if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4863                             sv_catpvs(msg, " (you may need to install the ");
4864                             for (c = name; c < e; c++) {
4865                                 if (*c == '/') {
4866                                     sv_catpvs(msg, "::");
4867                                 }
4868                                 else {
4869                                     sv_catpvn(msg, c, 1);
4870                                 }
4871                             }
4872                             sv_catpvs(msg, " module)");
4873                         }
4874                     }
4875                     else if (memENDs(name, len, ".h")) {
4876                         sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4877                     }
4878                     else if (memENDs(name, len, ".ph")) {
4879                         sv_catpvs(msg, " (did you run h2ph?)");
4880                     }
4881
4882                     /* diag_listed_as: Can't locate %s */
4883                     DIE(aTHX_
4884                         "Can't locate %s in @INC%" SVf " (@INC entries checked:%" SVf ")",
4885                         name, msg, inc);
4886                 }
4887             }
4888             DIE(aTHX_ "Can't locate %s", name);
4889         }
4890         else {
4891 #ifdef DEFAULT_INC_EXCLUDES_DOT
4892             Stat_t st;
4893             PerlIO *io = NULL;
4894             dSAVE_ERRNO;
4895             /* the complication is to match the logic from doopen_pm() so
4896              * we don't treat do "sda1" as a previously successful "do".
4897             */
4898             bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED__DOT_IN_INC)
4899                 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4900                 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4901             if (io)
4902                 PerlIO_close(io);
4903
4904             RESTORE_ERRNO;
4905             if (do_warn) {
4906                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED__DOT_IN_INC),
4907                 "do \"%s\" failed, '.' is no longer in @INC; "
4908                 "did you mean do \"./%s\"?",
4909                 name, name);
4910             }
4911 #endif
4912             CLEAR_ERRSV();
4913             RETPUSHUNDEF;
4914         }
4915     }
4916     else
4917         SETERRNO(0, SS_NORMAL);
4918
4919     /* Update %INC. Assume success here to prevent recursive requirement. */
4920     /* name is never assigned to again, so len is still strlen(name)  */
4921     /* Check whether a hook in @INC has already filled %INC */
4922     if (!hook_sv) {
4923         (void)hv_store(GvHVn(PL_incgv),
4924                        unixname, unixlen, newSVpv(tryname,0),0);
4925     } else {
4926         /* store the hook in the sv, note we have to *copy* hook_sv,
4927          * we don't want modifications to it to change @INC - see GH #20577
4928          */
4929         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4930         if (!svp)
4931             (void)hv_store(GvHVn(PL_incgv),
4932                            unixname, unixlen, newSVsv(hook_sv), 0 );
4933     }
4934
4935     /* Now parse the file */
4936
4937     old_savestack_ix = PL_savestack_ix;
4938     SAVECOPFILE_FREE(&PL_compiling);
4939     CopFILE_set(&PL_compiling, tryname);
4940     lex_start(NULL, tryrsfp, 0);
4941
4942     if (filter_sub || filter_cache) {
4943         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4944            than hanging another SV from it. In turn, filter_add() optionally
4945            takes the SV to use as the filter (or creates a new SV if passed
4946            NULL), so simply pass in whatever value filter_cache has.  */
4947         SV * const fc = filter_cache ? newSV_type(SVt_NULL) : NULL;
4948         SV *datasv;
4949         if (fc) sv_copypv(fc, filter_cache);
4950         datasv = filter_add(S_run_user_filter, fc);
4951         IoLINES(datasv) = filter_has_file;
4952         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4953         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4954     }
4955
4956     /* switch to eval mode */
4957     assert(!CATCH_GET);
4958     cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4959     cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4960
4961     SAVECOPLINE(&PL_compiling);
4962     CopLINE_set(&PL_compiling, 0);
4963
4964     PUTBACK;
4965
4966     if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4967         op = PL_eval_start;
4968     else
4969         op = PL_op->op_next;
4970
4971     PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4972
4973     return op;
4974 }
4975
4976
4977 /* also used for: pp_dofile() */
4978
4979 PP(pp_require)
4980 {
4981     /* If a suitable JMPENV catch frame isn't present, call docatch(),
4982      * which will:
4983      *   - add such a frame, and
4984      *   - start a new RUNOPS loop, which will (as the first op to run),
4985      *     recursively call this pp function again.
4986      * The main body of this function is then executed by the inner call.
4987      */
4988     if (CATCH_GET)
4989         return docatch(Perl_pp_require);
4990
4991     {
4992         dSP;
4993         SV *sv = POPs;
4994         SvGETMAGIC(sv);
4995         PUTBACK;
4996         return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4997             ? S_require_version(aTHX_ sv)
4998             : S_require_file(aTHX_ sv);
4999     }
5000 }
5001
5002
5003 /* This is a op added to hold the hints hash for
5004    pp_entereval. The hash can be modified by the code
5005    being eval'ed, so we return a copy instead. */
5006
5007 PP(pp_hintseval)
5008 {
5009     dSP;
5010     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
5011     RETURN;
5012 }
5013
5014
5015 PP(pp_entereval)
5016 {
5017     dSP;
5018     PERL_CONTEXT *cx;
5019     SV *sv;
5020     U8 gimme;
5021     U32 was;
5022     char tbuf[TYPE_DIGITS(long) + 12];
5023     bool saved_delete;
5024     char *tmpbuf;
5025     STRLEN len;
5026     CV* runcv;
5027     U32 seq, lex_flags;
5028     HV *saved_hh;
5029     bool bytes;
5030     I32 old_savestack_ix;
5031
5032     /* If a suitable JMPENV catch frame isn't present, call docatch(),
5033      * which will:
5034      *   - add such a frame, and
5035      *   - start a new RUNOPS loop, which will (as the first op to run),
5036      *     recursively call this pp function again.
5037      * The main body of this function is then executed by the inner call.
5038      */
5039     if (CATCH_GET)
5040         return docatch(Perl_pp_entereval);
5041
5042     assert(!CATCH_GET);
5043
5044     gimme = GIMME_V;
5045     was = PL_breakable_sub_gen;
5046     saved_delete = FALSE;
5047     tmpbuf = tbuf;
5048     lex_flags = 0;
5049     saved_hh = NULL;
5050     bytes = PL_op->op_private & OPpEVAL_BYTES;
5051
5052     if (PL_op->op_private & OPpEVAL_HAS_HH) {
5053         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
5054     }
5055     else if (PL_hints & HINT_LOCALIZE_HH || (
5056                 PL_op->op_private & OPpEVAL_COPHH
5057              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
5058             )) {
5059         saved_hh = cop_hints_2hv(PL_curcop, 0);
5060         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
5061     }
5062     sv = POPs;
5063     if (!SvPOK(sv)) {
5064         /* make sure we've got a plain PV (no overload etc) before testing
5065          * for taint. Making a copy here is probably overkill, but better
5066          * safe than sorry */
5067         STRLEN len;
5068         const char * const p = SvPV_const(sv, len);
5069
5070         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
5071         lex_flags |= LEX_START_COPIED;
5072
5073         if (bytes && SvUTF8(sv))
5074             SvPVbyte_force(sv, len);
5075     }
5076     else if (bytes && SvUTF8(sv)) {
5077         /* Don't modify someone else's scalar */
5078         STRLEN len;
5079         sv = newSVsv(sv);
5080         (void)sv_2mortal(sv);
5081         SvPVbyte_force(sv,len);
5082         lex_flags |= LEX_START_COPIED;
5083     }
5084
5085     TAINT_IF(SvTAINTED(sv));
5086     TAINT_PROPER("eval");
5087
5088     old_savestack_ix = PL_savestack_ix;
5089
5090     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
5091                            ? LEX_IGNORE_UTF8_HINTS
5092                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
5093                         )
5094              );
5095
5096     /* switch to eval mode */
5097
5098     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
5099         SV * const temp_sv = sv_newmortal();
5100         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" LINE_Tf "]",
5101                        (unsigned long)++PL_evalseq,
5102                        CopFILE(PL_curcop), CopLINE(PL_curcop));
5103         tmpbuf = SvPVX(temp_sv);
5104         len = SvCUR(temp_sv);
5105     }
5106     else
5107         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
5108     SAVECOPFILE_FREE(&PL_compiling);
5109     CopFILE_set(&PL_compiling, tmpbuf+2);
5110     SAVECOPLINE(&PL_compiling);
5111     CopLINE_set(&PL_compiling, 1);
5112     /* special case: an eval '' executed within the DB package gets lexically
5113      * placed in the first non-DB CV rather than the current CV - this
5114      * allows the debugger to execute code, find lexicals etc, in the