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