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_LIST:
  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_grepwhile() lives in pp_hot.c */
1006
1007 PP(pp_mapwhile)
1008 {
1009     dSP;
1010     const U8 gimme = GIMME_V;
1011     I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
1012     I32 count;
1013     I32 shift;
1014     SV** src;
1015     SV** dst;
1016
1017     /* first, move source pointer to the next item in the source list */
1018     ++PL_markstack_ptr[-1];
1019
1020     /* if there are new items, push them into the destination list */
1021     if (items && gimme != G_VOID) {
1022         /* might need to make room back there first */
1023         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1024             /* XXX this implementation is very pessimal because the stack
1025              * is repeatedly extended for every set of items.  Is possible
1026              * to do this without any stack extension or copying at all
1027              * by maintaining a separate list over which the map iterates
1028              * (like foreach does). --gsar */
1029
1030             /* everything in the stack after the destination list moves
1031              * towards the end the stack by the amount of room needed */
1032             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1033
1034             /* items to shift up (accounting for the moved source pointer) */
1035             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1036
1037             /* This optimization is by Ben Tilly and it does
1038              * things differently from what Sarathy (gsar)
1039              * is describing.  The downside of this optimization is
1040              * that leaves "holes" (uninitialized and hopefully unused areas)
1041              * to the Perl stack, but on the other hand this
1042              * shouldn't be a problem.  If Sarathy's idea gets
1043              * implemented, this optimization should become
1044              * irrelevant.  --jhi */
1045             if (shift < count)
1046                 shift = count; /* Avoid shifting too often --Ben Tilly */
1047
1048             EXTEND(SP,shift);
1049             src = SP;
1050             dst = (SP += shift);
1051             PL_markstack_ptr[-1] += shift;
1052             *PL_markstack_ptr += shift;
1053             while (count--)
1054                 *dst-- = *src--;
1055         }
1056         /* copy the new items down to the destination list */
1057         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1058         if (gimme == G_LIST) {
1059             /* add returned items to the collection (making mortal copies
1060              * if necessary), then clear the current temps stack frame
1061              * *except* for those items. We do this splicing the items
1062              * into the start of the tmps frame (so some items may be on
1063              * the tmps stack twice), then moving PL_tmps_floor above
1064              * them, then freeing the frame. That way, the only tmps that
1065              * accumulate over iterations are the return values for map.
1066              * We have to do to this way so that everything gets correctly
1067              * freed if we die during the map.
1068              */
1069             I32 tmpsbase;
1070             I32 i = items;
1071             /* make space for the slice */
1072             EXTEND_MORTAL(items);
1073             tmpsbase = PL_tmps_floor + 1;
1074             Move(PL_tmps_stack + tmpsbase,
1075                  PL_tmps_stack + tmpsbase + items,
1076                  PL_tmps_ix - PL_tmps_floor,
1077                  SV*);
1078             PL_tmps_ix += items;
1079
1080             while (i-- > 0) {
1081                 SV *sv = POPs;
1082                 if (!SvTEMP(sv))
1083                     sv = sv_mortalcopy(sv);
1084                 *dst-- = sv;
1085                 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1086             }
1087             /* clear the stack frame except for the items */
1088             PL_tmps_floor += items;
1089             FREETMPS;
1090             /* FREETMPS may have cleared the TEMP flag on some of the items */
1091             i = items;
1092             while (i-- > 0)
1093                 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1094         }
1095         else {
1096             /* scalar context: we don't care about which values map returns
1097              * (we use undef here). And so we certainly don't want to do mortal
1098              * copies of meaningless values. */
1099             while (items-- > 0) {
1100                 (void)POPs;
1101                 *dst-- = &PL_sv_undef;
1102             }
1103             FREETMPS;
1104         }
1105     }
1106     else {
1107         FREETMPS;
1108     }
1109     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1110
1111     /* All done yet? */
1112     if (PL_markstack_ptr[-1] > TOPMARK) {
1113
1114         (void)POPMARK;                          /* pop top */
1115         LEAVE_with_name("grep");                                        /* exit outer scope */
1116         (void)POPMARK;                          /* pop src */
1117         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1118         (void)POPMARK;                          /* pop dst */
1119         SP = PL_stack_base + POPMARK;           /* pop original mark */
1120         if (gimme == G_SCALAR) {
1121                 dTARGET;
1122                 XPUSHi(items);
1123         }
1124         else if (gimme == G_LIST)
1125             SP += items;
1126         RETURN;
1127     }
1128     else {
1129         SV *src;
1130
1131         ENTER_with_name("grep_item");                                   /* enter inner scope */
1132         SAVEVPTR(PL_curpm);
1133
1134         /* set $_ to the new source item */
1135         src = PL_stack_base[PL_markstack_ptr[-1]];
1136         if (SvPADTMP(src)) {
1137             src = sv_mortalcopy(src);
1138         }
1139         SvTEMP_off(src);
1140         DEFSV_set(src);
1141
1142         RETURNOP(cLOGOP->op_other);
1143     }
1144 }
1145
1146 /* Range stuff. */
1147
1148 PP(pp_range)
1149 {
1150     dTARG;
1151     if (GIMME_V == G_LIST)
1152         return NORMAL;
1153     GETTARGET;
1154     if (SvTRUE_NN(targ))
1155         return cLOGOP->op_other;
1156     else
1157         return NORMAL;
1158 }
1159
1160 PP(pp_flip)
1161 {
1162     dSP;
1163
1164     if (GIMME_V == G_LIST) {
1165         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1166     }
1167     else {
1168         dTOPss;
1169         SV * const targ = PAD_SV(PL_op->op_targ);
1170         int flip = 0;
1171
1172         if (PL_op->op_private & OPpFLIP_LINENUM) {
1173             if (GvIO(PL_last_in_gv)) {
1174                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1175             }
1176             else {
1177                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1178                 if (gv && GvSV(gv))
1179                     flip = SvIV(sv) == SvIV(GvSV(gv));
1180             }
1181         } else {
1182             flip = SvTRUE_NN(sv);
1183         }
1184         if (flip) {
1185             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1186             if (PL_op->op_flags & OPf_SPECIAL) {
1187                 sv_setiv(targ, 1);
1188                 SETs(targ);
1189                 RETURN;
1190             }
1191             else {
1192                 sv_setiv(targ, 0);
1193                 SP--;
1194                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1195             }
1196         }
1197         SvPVCLEAR(TARG);
1198         SETs(targ);
1199         RETURN;
1200     }
1201 }
1202
1203 /* This code tries to decide if "$left .. $right" should use the
1204    magical string increment, or if the range is numeric. Initially,
1205    an exception was made for *any* string beginning with "0" (see
1206    [#18165], AMS 20021031), but now that is only applied when the
1207    string's length is also >1 - see the rules now documented in
1208    perlop [#133695] */
1209
1210 #define RANGE_IS_NUMERIC(left,right) ( \
1211         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1212         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1213         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1214           looks_like_number(left)) && SvPOKp(left) \
1215           && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1216          && (!SvOK(right) || looks_like_number(right))))
1217
1218 PP(pp_flop)
1219 {
1220     dSP;
1221
1222     if (GIMME_V == G_LIST) {
1223         dPOPPOPssrl;
1224
1225         SvGETMAGIC(left);
1226         SvGETMAGIC(right);
1227
1228         if (RANGE_IS_NUMERIC(left,right)) {
1229             IV i, j, n;
1230             if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1231                 (SvOK(right) && (SvIOK(right)
1232                                  ? SvIsUV(right) && SvUV(right) > IV_MAX
1233                                  : SvNV_nomg(right) > (NV) IV_MAX)))
1234                 DIE(aTHX_ "Range iterator outside integer range");
1235             i = SvIV_nomg(left);
1236             j = SvIV_nomg(right);
1237             if (j >= i) {
1238                 /* Dance carefully around signed max. */
1239                 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1240                 if (!overflow) {
1241                     n = j - i + 1;
1242                     /* The wraparound of signed integers is undefined
1243                      * behavior, but here we aim for count >=1, and
1244                      * negative count is just wrong. */
1245                     if (n < 1
1246 #if IVSIZE > Size_t_size
1247                         || n > SSize_t_MAX
1248 #endif
1249                         )
1250                         overflow = TRUE;
1251                 }
1252                 if (overflow)
1253                     Perl_croak(aTHX_ "Out of memory during list extend");
1254                 EXTEND_MORTAL(n);
1255                 EXTEND(SP, n);
1256             }
1257             else
1258                 n = 0;
1259             while (n--) {
1260                 SV * const sv = sv_2mortal(newSViv(i));
1261                 PUSHs(sv);
1262                 if (n) /* avoid incrementing above IV_MAX */
1263                     i++;
1264             }
1265         }
1266         else {
1267             STRLEN len, llen;
1268             const char * const lpv = SvPV_nomg_const(left, llen);
1269             const char * const tmps = SvPV_nomg_const(right, len);
1270
1271             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1272             if (DO_UTF8(right) && IN_UNI_8_BIT)
1273                 len = sv_len_utf8_nomg(right);
1274             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1275                 XPUSHs(sv);
1276                 if (strEQ(SvPVX_const(sv),tmps))
1277                     break;
1278                 sv = sv_2mortal(newSVsv(sv));
1279                 sv_inc(sv);
1280             }
1281         }
1282     }
1283     else {
1284         dTOPss;
1285         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1286         int flop = 0;
1287         sv_inc(targ);
1288
1289         if (PL_op->op_private & OPpFLIP_LINENUM) {
1290             if (GvIO(PL_last_in_gv)) {
1291                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1292             }
1293             else {
1294                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1295                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1296             }
1297         }
1298         else {
1299             flop = SvTRUE_NN(sv);
1300         }
1301
1302         if (flop) {
1303             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1304             sv_catpvs(targ, "E0");
1305         }
1306         SETs(targ);
1307     }
1308
1309     RETURN;
1310 }
1311
1312 /* Control. */
1313
1314 static const char * const context_name[] = {
1315     "pseudo-block",
1316     NULL, /* CXt_WHEN never actually needs "block" */
1317     NULL, /* CXt_BLOCK never actually needs "block" */
1318     NULL, /* CXt_GIVEN never actually needs "block" */
1319     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1320     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1321     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1322     NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1323     NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1324     "subroutine",
1325     "format",
1326     "eval",
1327     "substitution",
1328     "defer block",
1329 };
1330
1331 STATIC I32
1332 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1333 {
1334     I32 i;
1335
1336     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1337
1338     for (i = cxstack_ix; i >= 0; i--) {
1339         const PERL_CONTEXT * const cx = &cxstack[i];
1340         switch (CxTYPE(cx)) {
1341         case CXt_EVAL:
1342             if(CxTRY(cx))
1343                 continue;
1344             /* FALLTHROUGH */
1345         case CXt_SUBST:
1346         case CXt_SUB:
1347         case CXt_FORMAT:
1348         case CXt_NULL:
1349             /* diag_listed_as: Exiting subroutine via %s */
1350             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1351                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1352             if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1353                 return -1;
1354             break;
1355         case CXt_LOOP_PLAIN:
1356         case CXt_LOOP_LAZYIV:
1357         case CXt_LOOP_LAZYSV:
1358         case CXt_LOOP_LIST:
1359         case CXt_LOOP_ARY:
1360           {
1361             STRLEN cx_label_len = 0;
1362             U32 cx_label_flags = 0;
1363             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1364             if (!cx_label || !(
1365                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1366                         (flags & SVf_UTF8)
1367                             ? (bytes_cmp_utf8(
1368                                         (const U8*)cx_label, cx_label_len,
1369                                         (const U8*)label, len) == 0)
1370                             : (bytes_cmp_utf8(
1371                                         (const U8*)label, len,
1372                                         (const U8*)cx_label, cx_label_len) == 0)
1373                     : (len == cx_label_len && ((cx_label == label)
1374                                     || memEQ(cx_label, label, len))) )) {
1375                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1376                         (long)i, cx_label));
1377                 continue;
1378             }
1379             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1380             return i;
1381           }
1382         }
1383     }
1384     return i;
1385 }
1386
1387
1388
1389 U8
1390 Perl_dowantarray(pTHX)
1391 {
1392     const U8 gimme = block_gimme();
1393     return (gimme == G_VOID) ? G_SCALAR : gimme;
1394 }
1395
1396 /* note that this function has mostly been superseded by Perl_gimme_V */
1397
1398 U8
1399 Perl_block_gimme(pTHX)
1400 {
1401     const I32 cxix = dopopto_cursub();
1402     U8 gimme;
1403     if (cxix < 0)
1404         return G_VOID;
1405
1406     gimme = (cxstack[cxix].blk_gimme & G_WANT);
1407     if (!gimme)
1408         Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1409     return gimme;
1410 }
1411
1412
1413 I32
1414 Perl_is_lvalue_sub(pTHX)
1415 {
1416     const I32 cxix = dopopto_cursub();
1417     assert(cxix >= 0);  /* We should only be called from inside subs */
1418
1419     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1420         return CxLVAL(cxstack + cxix);
1421     else
1422         return 0;
1423 }
1424
1425 /* only used by cx_pushsub() */
1426 I32
1427 Perl_was_lvalue_sub(pTHX)
1428 {
1429     const I32 cxix = dopoptosub(cxstack_ix-1);
1430     assert(cxix >= 0);  /* We should only be called from inside subs */
1431
1432     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1433         return CxLVAL(cxstack + cxix);
1434     else
1435         return 0;
1436 }
1437
1438 STATIC I32
1439 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1440 {
1441     I32 i;
1442
1443     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1444 #ifndef DEBUGGING
1445     PERL_UNUSED_CONTEXT;
1446 #endif
1447
1448     for (i = startingblock; i >= 0; i--) {
1449         const PERL_CONTEXT * const cx = &cxstk[i];
1450         switch (CxTYPE(cx)) {
1451         default:
1452             continue;
1453         case CXt_SUB:
1454             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1455              * twice; the first for the normal foo() call, and the second
1456              * for a faked up re-entry into the sub to execute the
1457              * code block. Hide this faked entry from the world. */
1458             if (cx->cx_type & CXp_SUB_RE_FAKE)
1459                 continue;
1460             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1461             return i;
1462
1463         case CXt_EVAL:
1464             if (CxTRY(cx))
1465                 continue;
1466             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1467             return i;
1468
1469         case CXt_FORMAT:
1470             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1471             return i;
1472         }
1473     }
1474     return i;
1475 }
1476
1477 STATIC I32
1478 S_dopoptoeval(pTHX_ I32 startingblock)
1479 {
1480     I32 i;
1481     for (i = startingblock; i >= 0; i--) {
1482         const PERL_CONTEXT *cx = &cxstack[i];
1483         switch (CxTYPE(cx)) {
1484         default:
1485             continue;
1486         case CXt_EVAL:
1487             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1488             return i;
1489         }
1490     }
1491     return i;
1492 }
1493
1494 STATIC I32
1495 S_dopoptoloop(pTHX_ I32 startingblock)
1496 {
1497     I32 i;
1498     for (i = startingblock; i >= 0; i--) {
1499         const PERL_CONTEXT * const cx = &cxstack[i];
1500         switch (CxTYPE(cx)) {
1501         case CXt_EVAL:
1502             if(CxTRY(cx))
1503                 continue;
1504             /* FALLTHROUGH */
1505         case CXt_SUBST:
1506         case CXt_SUB:
1507         case CXt_FORMAT:
1508         case CXt_NULL:
1509             /* diag_listed_as: Exiting subroutine via %s */
1510             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1511                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1512             if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1513                 return -1;
1514             break;
1515         case CXt_LOOP_PLAIN:
1516         case CXt_LOOP_LAZYIV:
1517         case CXt_LOOP_LAZYSV:
1518         case CXt_LOOP_LIST:
1519         case CXt_LOOP_ARY:
1520             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1521             return i;
1522         }
1523     }
1524     return i;
1525 }
1526
1527 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1528
1529 STATIC I32
1530 S_dopoptogivenfor(pTHX_ I32 startingblock)
1531 {
1532     I32 i;
1533     for (i = startingblock; i >= 0; i--) {
1534         const PERL_CONTEXT *cx = &cxstack[i];
1535         switch (CxTYPE(cx)) {
1536         default:
1537             continue;
1538         case CXt_GIVEN:
1539             DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1540             return i;
1541         case CXt_LOOP_PLAIN:
1542             assert(!(cx->cx_type & CXp_FOR_DEF));
1543             break;
1544         case CXt_LOOP_LAZYIV:
1545         case CXt_LOOP_LAZYSV:
1546         case CXt_LOOP_LIST:
1547         case CXt_LOOP_ARY:
1548             if (cx->cx_type & CXp_FOR_DEF) {
1549                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1550                 return i;
1551             }
1552         }
1553     }
1554     return i;
1555 }
1556
1557 STATIC I32
1558 S_dopoptowhen(pTHX_ I32 startingblock)
1559 {
1560     I32 i;
1561     for (i = startingblock; i >= 0; i--) {
1562         const PERL_CONTEXT *cx = &cxstack[i];
1563         switch (CxTYPE(cx)) {
1564         default:
1565             continue;
1566         case CXt_WHEN:
1567             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1568             return i;
1569         }
1570     }
1571     return i;
1572 }
1573
1574 /* dounwind(): pop all contexts above (but not including) cxix.
1575  * Note that it clears the savestack frame associated with each popped
1576  * context entry, but doesn't free any temps.
1577  * It does a cx_popblock() of the last frame that it pops, and leaves
1578  * cxstack_ix equal to cxix.
1579  */
1580
1581 void
1582 Perl_dounwind(pTHX_ I32 cxix)
1583 {
1584     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1585         return;
1586
1587     while (cxstack_ix > cxix) {
1588         PERL_CONTEXT *cx = CX_CUR();
1589
1590         CX_DEBUG(cx, "UNWIND");
1591         /* Note: we don't need to restore the base context info till the end. */
1592
1593         CX_LEAVE_SCOPE(cx);
1594
1595         switch (CxTYPE(cx)) {
1596         case CXt_SUBST:
1597             CX_POPSUBST(cx);
1598             /* CXt_SUBST is not a block context type, so skip the
1599              * cx_popblock(cx) below */
1600             if (cxstack_ix == cxix + 1) {
1601                 cxstack_ix--;
1602                 return;
1603             }
1604             break;
1605         case CXt_SUB:
1606             cx_popsub(cx);
1607             break;
1608         case CXt_EVAL:
1609             cx_popeval(cx);
1610             break;
1611         case CXt_LOOP_PLAIN:
1612         case CXt_LOOP_LAZYIV:
1613         case CXt_LOOP_LAZYSV:
1614         case CXt_LOOP_LIST:
1615         case CXt_LOOP_ARY:
1616             cx_poploop(cx);
1617             break;
1618         case CXt_WHEN:
1619             cx_popwhen(cx);
1620             break;
1621         case CXt_GIVEN:
1622             cx_popgiven(cx);
1623             break;
1624         case CXt_BLOCK:
1625         case CXt_NULL:
1626         case CXt_DEFER:
1627             /* these two don't have a POPFOO() */
1628             break;
1629         case CXt_FORMAT:
1630             cx_popformat(cx);
1631             break;
1632         }
1633         if (cxstack_ix == cxix + 1) {
1634             cx_popblock(cx);
1635         }
1636         cxstack_ix--;
1637     }
1638
1639 }
1640
1641 void
1642 Perl_qerror(pTHX_ SV *err)
1643 {
1644     PERL_ARGS_ASSERT_QERROR;
1645
1646     if (PL_in_eval) {
1647         if (PL_in_eval & EVAL_KEEPERR) {
1648                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1649                                                     SVfARG(err));
1650         }
1651         else
1652             sv_catsv(ERRSV, err);
1653     }
1654     else if (PL_errors)
1655         sv_catsv(PL_errors, err);
1656     else
1657         Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1658     if (PL_parser)
1659         ++PL_parser->error_count;
1660 }
1661
1662
1663
1664 /* pop a CXt_EVAL context and in addition, if it was a require then
1665  * based on action:
1666  *     0: do nothing extra;
1667  *     1: undef  $INC{$name}; croak "$name did not return a true value";
1668  *     2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1669  */
1670
1671 static void
1672 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1673 {
1674     SV  *namesv = NULL; /* init to avoid dumb compiler warning */
1675     bool do_croak;
1676
1677     CX_LEAVE_SCOPE(cx);
1678     do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1679     if (do_croak) {
1680         /* keep namesv alive after cx_popeval() */
1681         namesv = cx->blk_eval.old_namesv;
1682         cx->blk_eval.old_namesv = NULL;
1683         sv_2mortal(namesv);
1684     }
1685     cx_popeval(cx);
1686     cx_popblock(cx);
1687     CX_POP(cx);
1688
1689     if (do_croak) {
1690         const char *fmt;
1691         HV *inc_hv = GvHVn(PL_incgv);
1692
1693         if (action == 1) {
1694             (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0);
1695             fmt = "%" SVf " did not return a true value";
1696             errsv = namesv;
1697         }
1698         else {
1699             (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0);
1700             fmt = "%" SVf "Compilation failed in require";
1701             if (!errsv)
1702                 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1703         }
1704
1705         Perl_croak(aTHX_ fmt, SVfARG(errsv));
1706     }
1707 }
1708
1709
1710 /* die_unwind(): this is the final destination for the various croak()
1711  * functions. If we're in an eval, unwind the context and other stacks
1712  * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1713  * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1714  * to is a require the exception will be rethrown, as requires don't
1715  * actually trap exceptions.
1716  */
1717
1718 void
1719 Perl_die_unwind(pTHX_ SV *msv)
1720 {
1721     SV *exceptsv = msv;
1722     U8 in_eval = PL_in_eval;
1723     PERL_ARGS_ASSERT_DIE_UNWIND;
1724
1725     if (in_eval) {
1726         I32 cxix;
1727
1728         /* We need to keep this SV alive through all the stack unwinding
1729          * and FREETMPSing below, while ensuing that it doesn't leak
1730          * if we call out to something which then dies (e.g. sub STORE{die}
1731          * when unlocalising a tied var). So we do a dance with
1732          * mortalising and SAVEFREEing.
1733          */
1734         if (PL_phase == PERL_PHASE_DESTRUCT) {
1735             exceptsv = sv_mortalcopy(exceptsv);
1736         } else {
1737             exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1738         }
1739
1740         /*
1741          * Historically, perl used to set ERRSV ($@) early in the die
1742          * process and rely on it not getting clobbered during unwinding.
1743          * That sucked, because it was liable to get clobbered, so the
1744          * setting of ERRSV used to emit the exception from eval{} has
1745          * been moved to much later, after unwinding (see just before
1746          * JMPENV_JUMP below).  However, some modules were relying on the
1747          * early setting, by examining $@ during unwinding to use it as
1748          * a flag indicating whether the current unwinding was caused by
1749          * an exception.  It was never a reliable flag for that purpose,
1750          * being totally open to false positives even without actual
1751          * clobberage, but was useful enough for production code to
1752          * semantically rely on it.
1753          *
1754          * We'd like to have a proper introspective interface that
1755          * explicitly describes the reason for whatever unwinding
1756          * operations are currently in progress, so that those modules
1757          * work reliably and $@ isn't further overloaded.  But we don't
1758          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1759          * now *additionally* set here, before unwinding, to serve as the
1760          * (unreliable) flag that it used to.
1761          *
1762          * This behaviour is temporary, and should be removed when a
1763          * proper way to detect exceptional unwinding has been developed.
1764          * As of 2010-12, the authors of modules relying on the hack
1765          * are aware of the issue, because the modules failed on
1766          * perls 5.13.{1..7} which had late setting of $@ without this
1767          * early-setting hack.
1768          */
1769         if (!(in_eval & EVAL_KEEPERR)) {
1770             /* remove any read-only/magic from the SV, so we don't
1771                get infinite recursion when setting ERRSV */
1772             SANE_ERRSV();
1773             sv_setsv_flags(ERRSV, exceptsv,
1774                         (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1775         }
1776
1777         if (in_eval & EVAL_KEEPERR) {
1778             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1779                            SVfARG(exceptsv));
1780         }
1781
1782         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1783                && PL_curstackinfo->si_prev)
1784         {
1785             dounwind(-1);
1786             POPSTACK;
1787         }
1788
1789         if (cxix >= 0) {
1790             PERL_CONTEXT *cx;
1791             SV **oldsp;
1792             U8 gimme;
1793             JMPENV *restartjmpenv;
1794             OP *restartop;
1795
1796             if (cxix < cxstack_ix)
1797                 dounwind(cxix);
1798
1799             cx = CX_CUR();
1800             assert(CxTYPE(cx) == CXt_EVAL);
1801
1802             /* return false to the caller of eval */
1803             oldsp = PL_stack_base + cx->blk_oldsp;
1804             gimme = cx->blk_gimme;
1805             if (gimme == G_SCALAR)
1806                 *++oldsp = &PL_sv_undef;
1807             PL_stack_sp = oldsp;
1808
1809             restartjmpenv = cx->blk_eval.cur_top_env;
1810             restartop     = cx->blk_eval.retop;
1811
1812             /* We need a FREETMPS here to avoid late-called destructors
1813              * clobbering $@ *after* we set it below, e.g.
1814              *    sub DESTROY { eval { die "X" } }
1815              *    eval { my $x = bless []; die $x = 0, "Y" };
1816              *    is($@, "Y")
1817              * Here the clearing of the $x ref mortalises the anon array,
1818              * which needs to be freed *before* $& is set to "Y",
1819              * otherwise it gets overwritten with "X".
1820              *
1821              * However, the FREETMPS will clobber exceptsv, so preserve it
1822              * on the savestack for now.
1823              */
1824             SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1825             FREETMPS;
1826             /* now we're about to pop the savestack, so re-mortalise it */
1827             sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1828
1829             /* Note that unlike pp_entereval, pp_require isn't supposed to
1830              * trap errors. So if we're a require, after we pop the
1831              * CXt_EVAL that pp_require pushed, rethrow the error with
1832              * croak(exceptsv). This is all handled by the call below when
1833              * action == 2.
1834              */
1835             S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1836
1837             if (!(in_eval & EVAL_KEEPERR)) {
1838                 SANE_ERRSV();
1839                 sv_setsv(ERRSV, exceptsv);
1840             }
1841             PL_restartjmpenv = restartjmpenv;
1842             PL_restartop = restartop;
1843             JMPENV_JUMP(3);
1844             NOT_REACHED; /* NOTREACHED */
1845         }
1846     }
1847
1848     write_to_stderr(exceptsv);
1849     my_failure_exit();
1850     NOT_REACHED; /* NOTREACHED */
1851 }
1852
1853 PP(pp_xor)
1854 {
1855     dSP; dPOPTOPssrl;
1856     if (SvTRUE_NN(left) != SvTRUE_NN(right))
1857         RETSETYES;
1858     else
1859         RETSETNO;
1860 }
1861
1862 /*
1863
1864 =for apidoc_section $CV
1865
1866 =for apidoc caller_cx
1867
1868 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1869 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1870 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1871 stack frame, so C<caller_cx(0, NULL)> will return information for the
1872 immediately-surrounding Perl code.
1873
1874 This function skips over the automatic calls to C<&DB::sub> made on the
1875 behalf of the debugger.  If the stack frame requested was a sub called by
1876 C<DB::sub>, the return value will be the frame for the call to
1877 C<DB::sub>, since that has the correct line number/etc. for the call
1878 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1879 frame for the sub call itself.
1880
1881 =cut
1882 */
1883
1884 const PERL_CONTEXT *
1885 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1886 {
1887     I32 cxix = dopopto_cursub();
1888     const PERL_CONTEXT *cx;
1889     const PERL_CONTEXT *ccstack = cxstack;
1890     const PERL_SI *top_si = PL_curstackinfo;
1891
1892     for (;;) {
1893         /* we may be in a higher stacklevel, so dig down deeper */
1894         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1895             top_si = top_si->si_prev;
1896             ccstack = top_si->si_cxstack;
1897             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1898         }
1899         if (cxix < 0)
1900             return NULL;
1901         /* caller() should not report the automatic calls to &DB::sub */
1902         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1903                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1904             count++;
1905         if (!count--)
1906             break;
1907         cxix = dopoptosub_at(ccstack, cxix - 1);
1908     }
1909
1910     cx = &ccstack[cxix];
1911     if (dbcxp) *dbcxp = cx;
1912
1913     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1914         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1915         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1916            field below is defined for any cx. */
1917         /* caller() should not report the automatic calls to &DB::sub */
1918         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1919             cx = &ccstack[dbcxix];
1920     }
1921
1922     return cx;
1923 }
1924
1925 PP(pp_caller)
1926 {
1927     dSP;
1928     const PERL_CONTEXT *cx;
1929     const PERL_CONTEXT *dbcx;
1930     U8 gimme = GIMME_V;
1931     const HEK *stash_hek;
1932     I32 count = 0;
1933     bool has_arg = MAXARG && TOPs;
1934     const COP *lcop;
1935
1936     if (MAXARG) {
1937       if (has_arg)
1938         count = POPi;
1939       else (void)POPs;
1940     }
1941
1942     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1943     if (!cx) {
1944         if (gimme != G_LIST) {
1945             EXTEND(SP, 1);
1946             RETPUSHUNDEF;
1947         }
1948         RETURN;
1949     }
1950
1951     CX_DEBUG(cx, "CALLER");
1952     assert(CopSTASH(cx->blk_oldcop));
1953     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1954       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1955       : NULL;
1956     if (gimme != G_LIST) {
1957         EXTEND(SP, 1);
1958         if (!stash_hek)
1959             PUSHs(&PL_sv_undef);
1960         else {
1961             dTARGET;
1962             sv_sethek(TARG, stash_hek);
1963             PUSHs(TARG);
1964         }
1965         RETURN;
1966     }
1967
1968     EXTEND(SP, 11);
1969
1970     if (!stash_hek)
1971         PUSHs(&PL_sv_undef);
1972     else {
1973         dTARGET;
1974         sv_sethek(TARG, stash_hek);
1975         PUSHTARG;
1976     }
1977     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1978     lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1979                        cx->blk_sub.retop, TRUE);
1980     if (!lcop)
1981         lcop = cx->blk_oldcop;
1982     mPUSHu(CopLINE(lcop));
1983     if (!has_arg)
1984         RETURN;
1985     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1986         /* So is ccstack[dbcxix]. */
1987         if (CvHASGV(dbcx->blk_sub.cv)) {
1988             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1989             PUSHs(boolSV(CxHASARGS(cx)));
1990         }
1991         else {
1992             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1993             PUSHs(boolSV(CxHASARGS(cx)));
1994         }
1995     }
1996     else {
1997         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1998         PUSHs(&PL_sv_zero);
1999     }
2000     gimme = cx->blk_gimme;
2001     if (gimme == G_VOID)
2002         PUSHs(&PL_sv_undef);
2003     else
2004         PUSHs(boolSV((gimme & G_WANT) == G_LIST));
2005     if (CxTYPE(cx) == CXt_EVAL) {
2006         /* eval STRING */
2007         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
2008             SV *cur_text = cx->blk_eval.cur_text;
2009             if (SvCUR(cur_text) >= 2) {
2010                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
2011                                      SvUTF8(cur_text)|SVs_TEMP));
2012             }
2013             else {
2014                 /* I think this is will always be "", but be sure */
2015                 PUSHs(sv_2mortal(newSVsv(cur_text)));
2016             }
2017
2018             PUSHs(&PL_sv_no);
2019         }
2020         /* require */
2021         else if (cx->blk_eval.old_namesv) {
2022             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2023             PUSHs(&PL_sv_yes);
2024         }
2025         /* eval BLOCK (try blocks have old_namesv == 0) */
2026         else {
2027             PUSHs(&PL_sv_undef);
2028             PUSHs(&PL_sv_undef);
2029         }
2030     }
2031     else {
2032         PUSHs(&PL_sv_undef);
2033         PUSHs(&PL_sv_undef);
2034     }
2035     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2036         && CopSTASH_eq(PL_curcop, PL_debstash))
2037     {
2038         /* slot 0 of the pad contains the original @_ */
2039         AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2040                             PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2041                                 cx->blk_sub.olddepth+1]))[0]);
2042         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2043
2044         Perl_init_dbargs(aTHX);
2045
2046         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2047             av_extend(PL_dbargs, AvFILLp(ary) + off);
2048         if (AvFILLp(ary) + 1 + off)
2049             Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
2050         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2051     }
2052     mPUSHi(CopHINTS_get(cx->blk_oldcop));
2053     {
2054         SV * mask ;
2055         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2056
2057         if  (old_warnings == pWARN_NONE)
2058             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2059         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2060             mask = &PL_sv_undef ;
2061         else if (old_warnings == pWARN_ALL ||
2062                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2063             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2064         }
2065         else
2066             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2067         mPUSHs(mask);
2068     }
2069
2070     PUSHs(cx->blk_oldcop->cop_hints_hash ?
2071           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2072           : &PL_sv_undef);
2073     RETURN;
2074 }
2075
2076 PP(pp_reset)
2077 {
2078     dSP;
2079     const char * tmps;
2080     STRLEN len = 0;
2081     if (MAXARG < 1 || (!TOPs && !POPs)) {
2082         EXTEND(SP, 1);
2083         tmps = NULL, len = 0;
2084     }
2085     else
2086         tmps = SvPVx_const(POPs, len);
2087     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2088     PUSHs(&PL_sv_yes);
2089     RETURN;
2090 }
2091
2092 /* like pp_nextstate, but used instead when the debugger is active */
2093
2094 PP(pp_dbstate)
2095 {
2096     PL_curcop = (COP*)PL_op;
2097     TAINT_NOT;          /* Each statement is presumed innocent */
2098     PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2099     FREETMPS;
2100
2101     PERL_ASYNC_CHECK();
2102
2103     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2104             || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2105     {
2106         dSP;
2107         PERL_CONTEXT *cx;
2108         const U8 gimme = G_LIST;
2109         GV * const gv = PL_DBgv;
2110         CV * cv = NULL;
2111
2112         if (gv && isGV_with_GP(gv))
2113             cv = GvCV(gv);
2114
2115         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2116             DIE(aTHX_ "No DB::DB routine defined");
2117
2118         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2119             /* don't do recursive DB::DB call */
2120             return NORMAL;
2121
2122         if (CvISXSUB(cv)) {
2123             ENTER;
2124             SAVEI32(PL_debug);
2125             PL_debug = 0;
2126             SAVESTACK_POS();
2127             SAVETMPS;
2128             PUSHMARK(SP);
2129             (void)(*CvXSUB(cv))(aTHX_ cv);
2130             FREETMPS;
2131             LEAVE;
2132             return NORMAL;
2133         }
2134         else {
2135             cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2136             cx_pushsub(cx, cv, PL_op->op_next, 0);
2137             /* OP_DBSTATE's op_private holds hint bits rather than
2138              * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2139              * any CxLVAL() flags that have now been mis-calculated */
2140             cx->blk_u16 = 0;
2141
2142             SAVEI32(PL_debug);
2143             PL_debug = 0;
2144             SAVESTACK_POS();
2145             CvDEPTH(cv)++;
2146             if (CvDEPTH(cv) >= 2)
2147                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2148             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2149             RETURNOP(CvSTART(cv));
2150         }
2151     }
2152     else
2153         return NORMAL;
2154 }
2155
2156
2157 PP(pp_enter)
2158 {
2159     U8 gimme = GIMME_V;
2160
2161     (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2162     return NORMAL;
2163 }
2164
2165
2166 PP(pp_leave)
2167 {
2168     PERL_CONTEXT *cx;
2169     SV **oldsp;
2170     U8 gimme;
2171
2172     cx = CX_CUR();
2173     assert(CxTYPE(cx) == CXt_BLOCK);
2174
2175     if (PL_op->op_flags & OPf_SPECIAL)
2176         /* fake block should preserve $1 et al; e.g.  /(...)/ while ...; */
2177         cx->blk_oldpm = PL_curpm;
2178
2179     oldsp = PL_stack_base + cx->blk_oldsp;
2180     gimme = cx->blk_gimme;
2181
2182     if (gimme == G_VOID)
2183         PL_stack_sp = oldsp;
2184     else
2185         leave_adjust_stacks(oldsp, oldsp, gimme,
2186                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2187
2188     CX_LEAVE_SCOPE(cx);
2189     cx_popblock(cx);
2190     CX_POP(cx);
2191
2192     return NORMAL;
2193 }
2194
2195 static bool
2196 S_outside_integer(pTHX_ SV *sv)
2197 {
2198   if (SvOK(sv)) {
2199     const NV nv = SvNV_nomg(sv);
2200     if (Perl_isinfnan(nv))
2201       return TRUE;
2202 #ifdef NV_PRESERVES_UV
2203     if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2204       return TRUE;
2205 #else
2206     if (nv <= (NV)IV_MIN)
2207       return TRUE;
2208     if ((nv > 0) &&
2209         ((nv > (NV)UV_MAX ||
2210           SvUV_nomg(sv) > (UV)IV_MAX)))
2211       return TRUE;
2212 #endif
2213   }
2214   return FALSE;
2215 }
2216
2217 PP(pp_enteriter)
2218 {
2219     dSP; dMARK;
2220     PERL_CONTEXT *cx;
2221     const U8 gimme = GIMME_V;
2222     void *itervarp; /* GV or pad slot of the iteration variable */
2223     SV   *itersave; /* the old var in the iterator var slot */
2224     U8 cxflags = 0;
2225
2226     if (PL_op->op_targ) {                        /* "my" variable */
2227         itervarp = &PAD_SVl(PL_op->op_targ);
2228         itersave = *(SV**)itervarp;
2229         assert(itersave);
2230         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2231             /* the SV currently in the pad slot is never live during
2232              * iteration (the slot is always aliased to one of the items)
2233              * so it's always stale */
2234             SvPADSTALE_on(itersave);
2235         }
2236         SvREFCNT_inc_simple_void_NN(itersave);
2237         cxflags = CXp_FOR_PAD;
2238     }
2239     else {
2240         SV * const sv = POPs;
2241         itervarp = (void *)sv;
2242         if (LIKELY(isGV(sv))) {         /* symbol table variable */
2243             itersave = GvSV(sv);
2244             SvREFCNT_inc_simple_void(itersave);
2245             cxflags = CXp_FOR_GV;
2246             if (PL_op->op_private & OPpITER_DEF)
2247                 cxflags |= CXp_FOR_DEF;
2248         }
2249         else {                          /* LV ref: for \$foo (...) */
2250             assert(SvTYPE(sv) == SVt_PVMG);
2251             assert(SvMAGIC(sv));
2252             assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2253             itersave = NULL;
2254             cxflags = CXp_FOR_LVREF;
2255         }
2256     }
2257     /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2258     assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2259
2260     /* Note that this context is initially set as CXt_NULL. Further on
2261      * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2262      * there mustn't be anything in the blk_loop substruct that requires
2263      * freeing or undoing, in case we die in the meantime. And vice-versa.
2264      */
2265     cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2266     cx_pushloop_for(cx, itervarp, itersave);
2267
2268     if (PL_op->op_flags & OPf_STACKED) {
2269         /* OPf_STACKED implies either a single array: for(@), with a
2270          * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2271          * the stack */
2272         SV *maybe_ary = POPs;
2273         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2274             /* range */
2275             dPOPss;
2276             SV * const right = maybe_ary;
2277             if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2278                 DIE(aTHX_ "Assigned value is not a reference");
2279             SvGETMAGIC(sv);
2280             SvGETMAGIC(right);
2281             if (RANGE_IS_NUMERIC(sv,right)) {
2282                 cx->cx_type |= CXt_LOOP_LAZYIV;
2283                 if (S_outside_integer(aTHX_ sv) ||
2284                     S_outside_integer(aTHX_ right))
2285                     DIE(aTHX_ "Range iterator outside integer range");
2286                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2287                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2288             }
2289             else {
2290                 cx->cx_type |= CXt_LOOP_LAZYSV;
2291                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2292                 cx->blk_loop.state_u.lazysv.end = right;
2293                 SvREFCNT_inc_simple_void_NN(right);
2294                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2295                 /* This will do the upgrade to SVt_PV, and warn if the value
2296                    is uninitialised.  */
2297                 (void) SvPV_nolen_const(right);
2298                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2299                    to replace !SvOK() with a pointer to "".  */
2300                 if (!SvOK(right)) {
2301                     SvREFCNT_dec(right);
2302                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2303                 }
2304             }
2305         }
2306         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2307             /* for (@array) {} */
2308             cx->cx_type |= CXt_LOOP_ARY;
2309             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2310             SvREFCNT_inc_simple_void_NN(maybe_ary);
2311             cx->blk_loop.state_u.ary.ix =
2312                 (PL_op->op_private & OPpITER_REVERSED) ?
2313                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2314                 -1;
2315         }
2316         /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2317     }
2318     else { /* iterating over items on the stack */
2319         cx->cx_type |= CXt_LOOP_LIST;
2320         cx->blk_oldsp = SP - PL_stack_base;
2321         cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2322         cx->blk_loop.state_u.stack.ix =
2323             (PL_op->op_private & OPpITER_REVERSED)
2324                 ? cx->blk_oldsp + 1
2325                 : cx->blk_loop.state_u.stack.basesp;
2326         /* pre-extend stack so pp_iter doesn't have to check every time
2327          * it pushes yes/no */
2328         EXTEND(SP, 1);
2329     }
2330
2331     RETURN;
2332 }
2333
2334 PP(pp_enterloop)
2335 {
2336     PERL_CONTEXT *cx;
2337     const U8 gimme = GIMME_V;
2338
2339     cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2340     cx_pushloop_plain(cx);
2341     return NORMAL;
2342 }
2343
2344
2345 PP(pp_leaveloop)
2346 {
2347     PERL_CONTEXT *cx;
2348     U8 gimme;
2349     SV **base;
2350     SV **oldsp;
2351
2352     cx = CX_CUR();
2353     assert(CxTYPE_is_LOOP(cx));
2354     oldsp = PL_stack_base + cx->blk_oldsp;
2355     base = CxTYPE(cx) == CXt_LOOP_LIST
2356                 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2357                 : oldsp;
2358     gimme = cx->blk_gimme;
2359
2360     if (gimme == G_VOID)
2361         PL_stack_sp = base;
2362     else
2363         leave_adjust_stacks(oldsp, base, gimme,
2364                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2365
2366     CX_LEAVE_SCOPE(cx);
2367     cx_poploop(cx);     /* Stack values are safe: release loop vars ... */
2368     cx_popblock(cx);
2369     CX_POP(cx);
2370
2371     return NORMAL;
2372 }
2373
2374
2375 /* This duplicates most of pp_leavesub, but with additional code to handle
2376  * return args in lvalue context. It was forked from pp_leavesub to
2377  * avoid slowing down that function any further.
2378  *
2379  * Any changes made to this function may need to be copied to pp_leavesub
2380  * and vice-versa.
2381  *
2382  * also tail-called by pp_return
2383  */
2384
2385 PP(pp_leavesublv)
2386 {
2387     U8 gimme;
2388     PERL_CONTEXT *cx;
2389     SV **oldsp;
2390     OP *retop;
2391
2392     cx = CX_CUR();
2393     assert(CxTYPE(cx) == CXt_SUB);
2394
2395     if (CxMULTICALL(cx)) {
2396         /* entry zero of a stack is always PL_sv_undef, which
2397          * simplifies converting a '()' return into undef in scalar context */
2398         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2399         return 0;
2400     }
2401
2402     gimme = cx->blk_gimme;
2403     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2404
2405     if (gimme == G_VOID)
2406         PL_stack_sp = oldsp;
2407     else {
2408         U8   lval    = CxLVAL(cx);
2409         bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2410         const char *what = NULL;
2411
2412         if (gimme == G_SCALAR) {
2413             if (is_lval) {
2414                 /* check for bad return arg */
2415                 if (oldsp < PL_stack_sp) {
2416                     SV *sv = *PL_stack_sp;
2417                     if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2418                         what =
2419                             SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2420                             : "a readonly value" : "a temporary";
2421                     }
2422                     else goto ok;
2423                 }
2424                 else {
2425                     /* sub:lvalue{} will take us here. */
2426                     what = "undef";
2427                 }
2428               croak:
2429                 Perl_croak(aTHX_
2430                           "Can't return %s from lvalue subroutine", what);
2431             }
2432
2433           ok:
2434             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2435
2436             if (lval & OPpDEREF) {
2437                 /* lval_sub()->{...} and similar */
2438                 dSP;
2439                 SvGETMAGIC(TOPs);
2440                 if (!SvOK(TOPs)) {
2441                     TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2442                 }
2443                 PUTBACK;
2444             }
2445         }
2446         else {
2447             assert(gimme == G_LIST);
2448             assert (!(lval & OPpDEREF));
2449
2450             if (is_lval) {
2451                 /* scan for bad return args */
2452                 SV **p;
2453                 for (p = PL_stack_sp; p > oldsp; p--) {
2454                     SV *sv = *p;
2455                     /* the PL_sv_undef exception is to allow things like
2456                      * this to work, where PL_sv_undef acts as 'skip'
2457                      * placeholder on the LHS of list assigns:
2458                      *    sub foo :lvalue { undef }
2459                      *    ($a, undef, foo(), $b) = 1..4;
2460                      */
2461                     if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2462                     {
2463                         /* Might be flattened array after $#array =  */
2464                         what = SvREADONLY(sv)
2465                                 ? "a readonly value" : "a temporary";
2466                         goto croak;
2467                     }
2468                 }
2469             }
2470
2471             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2472         }
2473     }
2474
2475     CX_LEAVE_SCOPE(cx);
2476     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
2477     cx_popblock(cx);
2478     retop =  cx->blk_sub.retop;
2479     CX_POP(cx);
2480
2481     return retop;
2482 }
2483
2484
2485 PP(pp_return)
2486 {
2487     dSP; dMARK;
2488     PERL_CONTEXT *cx;
2489     I32 cxix = dopopto_cursub();
2490
2491     assert(cxstack_ix >= 0);
2492     if (cxix < cxstack_ix) {
2493         I32 i;
2494         /* Check for  defer { return; } */
2495         for(i = cxstack_ix; i > cxix; i--) {
2496             if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2497                 Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", "return");
2498         }
2499         if (cxix < 0) {
2500             if (!(       PL_curstackinfo->si_type == PERLSI_SORT
2501                   || (   PL_curstackinfo->si_type == PERLSI_MULTICALL
2502                       && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2503                  )
2504             )
2505                 DIE(aTHX_ "Can't return outside a subroutine");
2506             /* We must be in:
2507              *  a sort block, which is a CXt_NULL not a CXt_SUB;
2508              *  or a /(?{...})/ block.
2509              * Handle specially. */
2510             assert(CxTYPE(&cxstack[0]) == CXt_NULL
2511                     || (   CxTYPE(&cxstack[0]) == CXt_SUB
2512                         && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2513             if (cxstack_ix > 0) {
2514                 /* See comment below about context popping. Since we know
2515                  * we're scalar and not lvalue, we can preserve the return
2516                  * value in a simpler fashion than there. */
2517                 SV *sv = *SP;
2518                 assert(cxstack[0].blk_gimme == G_SCALAR);
2519                 if (   (sp != PL_stack_base)
2520                     && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2521                 )
2522                     *SP = sv_mortalcopy(sv);
2523                 dounwind(0);
2524             }
2525             /* caller responsible for popping cxstack[0] */
2526             return 0;
2527         }
2528
2529         /* There are contexts that need popping. Doing this may free the
2530          * return value(s), so preserve them first: e.g. popping the plain
2531          * loop here would free $x:
2532          *     sub f {  { my $x = 1; return $x } }
2533          * We may also need to shift the args down; for example,
2534          *    for (1,2) { return 3,4 }
2535          * leaves 1,2,3,4 on the stack. Both these actions will be done by
2536          * leave_adjust_stacks(), along with freeing any temps. Note that
2537          * whoever we tail-call (e.g. pp_leaveeval) will also call
2538          * leave_adjust_stacks(); however, the second call is likely to
2539          * just see a bunch of SvTEMPs with a ref count of 1, and so just
2540          * pass them through, rather than copying them again. So this
2541          * isn't as inefficient as it sounds.
2542          */
2543         cx = &cxstack[cxix];
2544         PUTBACK;
2545         if (cx->blk_gimme != G_VOID)
2546             leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2547                     cx->blk_gimme,
2548                     CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2549                         ? 3 : 0);
2550         SPAGAIN;
2551         dounwind(cxix);
2552         cx = &cxstack[cxix]; /* CX stack may have been realloced */
2553     }
2554     else {
2555         /* Like in the branch above, we need to handle any extra junk on
2556          * the stack. But because we're not also popping extra contexts, we
2557          * don't have to worry about prematurely freeing args. So we just
2558          * need to do the bare minimum to handle junk, and leave the main
2559          * arg processing in the function we tail call, e.g. pp_leavesub.
2560          * In list context we have to splice out the junk; in scalar
2561          * context we can leave as-is (pp_leavesub will later return the
2562          * top stack element). But for an  empty arg list, e.g.
2563          *    for (1,2) { return }
2564          * we need to set sp = oldsp so that pp_leavesub knows to push
2565          * &PL_sv_undef onto the stack.
2566          */
2567         SV **oldsp;
2568         cx = &cxstack[cxix];
2569         oldsp = PL_stack_base + cx->blk_oldsp;
2570         if (oldsp != MARK) {
2571             SSize_t nargs = SP - MARK;
2572             if (nargs) {
2573                 if (cx->blk_gimme == G_LIST) {
2574                     /* shift return args to base of call stack frame */
2575                     Move(MARK + 1, oldsp + 1, nargs, SV*);
2576                     PL_stack_sp  = oldsp + nargs;
2577                 }
2578             }
2579             else
2580                 PL_stack_sp  = oldsp;
2581         }
2582     }
2583
2584     /* fall through to a normal exit */
2585     switch (CxTYPE(cx)) {
2586     case CXt_EVAL:
2587         return CxEVALBLOCK(cx)
2588             ? Perl_pp_leavetry(aTHX)
2589             : Perl_pp_leaveeval(aTHX);
2590     case CXt_SUB:
2591         return CvLVALUE(cx->blk_sub.cv)
2592             ? Perl_pp_leavesublv(aTHX)
2593             : Perl_pp_leavesub(aTHX);
2594     case CXt_FORMAT:
2595         return Perl_pp_leavewrite(aTHX);
2596     default:
2597         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2598     }
2599 }
2600
2601 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2602
2603 static PERL_CONTEXT *
2604 S_unwind_loop(pTHX)
2605 {
2606     I32 cxix;
2607     if (PL_op->op_flags & OPf_SPECIAL) {
2608         cxix = dopoptoloop(cxstack_ix);
2609         if (cxix < 0)
2610             /* diag_listed_as: Can't "last" outside a loop block */
2611             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2612                 OP_NAME(PL_op));
2613     }
2614     else {
2615         dSP;
2616         STRLEN label_len;
2617         const char * const label =
2618             PL_op->op_flags & OPf_STACKED
2619                 ? SvPV(TOPs,label_len)
2620                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2621         const U32 label_flags =
2622             PL_op->op_flags & OPf_STACKED
2623                 ? SvUTF8(POPs)
2624                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2625         PUTBACK;
2626         cxix = dopoptolabel(label, label_len, label_flags);
2627         if (cxix < 0)
2628             /* diag_listed_as: Label not found for "last %s" */
2629             Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2630                                        OP_NAME(PL_op),
2631                                        SVfARG(PL_op->op_flags & OPf_STACKED
2632                                               && !SvGMAGICAL(TOPp1s)
2633                                               ? TOPp1s
2634                                               : newSVpvn_flags(label,
2635                                                     label_len,
2636                                                     label_flags | SVs_TEMP)));
2637     }
2638     if (cxix < cxstack_ix) {
2639         I32 i;
2640         /* Check for  defer { last ... } etc */
2641         for(i = cxstack_ix; i > cxix; i--) {
2642             if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2643                 Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", OP_NAME(PL_op));
2644         }
2645         dounwind(cxix);
2646     }
2647     return &cxstack[cxix];
2648 }
2649
2650
2651 PP(pp_last)
2652 {
2653     PERL_CONTEXT *cx;
2654     OP* nextop;
2655
2656     cx = S_unwind_loop(aTHX);
2657
2658     assert(CxTYPE_is_LOOP(cx));
2659     PL_stack_sp = PL_stack_base
2660                 + (CxTYPE(cx) == CXt_LOOP_LIST
2661                     ?  cx->blk_loop.state_u.stack.basesp
2662                     : cx->blk_oldsp
2663                 );
2664
2665     TAINT_NOT;
2666
2667     /* Stack values are safe: */
2668     CX_LEAVE_SCOPE(cx);
2669     cx_poploop(cx);     /* release loop vars ... */
2670     cx_popblock(cx);
2671     nextop = cx->blk_loop.my_op->op_lastop->op_next;
2672     CX_POP(cx);
2673
2674     return nextop;
2675 }
2676
2677 PP(pp_next)
2678 {
2679     PERL_CONTEXT *cx;
2680
2681     /* if not a bare 'next' in the main scope, search for it */
2682     cx = CX_CUR();
2683     if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2684         cx = S_unwind_loop(aTHX);
2685
2686     cx_topblock(cx);
2687     PL_curcop = cx->blk_oldcop;
2688     PERL_ASYNC_CHECK();
2689     return (cx)->blk_loop.my_op->op_nextop;
2690 }
2691
2692 PP(pp_redo)
2693 {
2694     PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2695     OP* redo_op = cx->blk_loop.my_op->op_redoop;
2696
2697     if (redo_op->op_type == OP_ENTER) {
2698         /* pop one less context to avoid $x being freed in while (my $x..) */
2699         cxstack_ix++;
2700         cx = CX_CUR();
2701         assert(CxTYPE(cx) == CXt_BLOCK);
2702         redo_op = redo_op->op_next;
2703     }
2704
2705     FREETMPS;
2706     CX_LEAVE_SCOPE(cx);
2707     cx_topblock(cx);
2708     PL_curcop = cx->blk_oldcop;
2709     PERL_ASYNC_CHECK();
2710     return redo_op;
2711 }
2712
2713 #define UNENTERABLE (OP *)1
2714 #define GOTO_DEPTH 64
2715
2716 STATIC OP *
2717 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2718 {
2719     OP **ops = opstack;
2720     static const char* const too_deep = "Target of goto is too deeply nested";
2721
2722     PERL_ARGS_ASSERT_DOFINDLABEL;
2723
2724     if (ops >= oplimit)
2725         Perl_croak(aTHX_ "%s", too_deep);
2726     if (o->op_type == OP_LEAVE ||
2727         o->op_type == OP_SCOPE ||
2728         o->op_type == OP_LEAVELOOP ||
2729         o->op_type == OP_LEAVESUB ||
2730         o->op_type == OP_LEAVETRY ||
2731         o->op_type == OP_LEAVEGIVEN)
2732     {
2733         *ops++ = cUNOPo->op_first;
2734     }
2735     else if (oplimit - opstack < GOTO_DEPTH) {
2736       if (o->op_flags & OPf_KIDS
2737           && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2738         *ops++ = UNENTERABLE;
2739       }
2740       else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2741           && OP_CLASS(o) != OA_LOGOP
2742           && o->op_type != OP_LINESEQ
2743           && o->op_type != OP_SREFGEN
2744           && o->op_type != OP_ENTEREVAL
2745           && o->op_type != OP_GLOB
2746           && o->op_type != OP_RV2CV) {
2747         OP * const kid = cUNOPo->op_first;
2748         if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2749             *ops++ = UNENTERABLE;
2750       }
2751     }
2752     if (ops >= oplimit)
2753         Perl_croak(aTHX_ "%s", too_deep);
2754     *ops = 0;
2755     if (o->op_flags & OPf_KIDS) {
2756         OP *kid;
2757         OP * const kid1 = cUNOPo->op_first;
2758         /* First try all the kids at this level, since that's likeliest. */
2759         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2760             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2761                 STRLEN kid_label_len;
2762                 U32 kid_label_flags;
2763                 const char *kid_label = CopLABEL_len_flags(kCOP,
2764                                                     &kid_label_len, &kid_label_flags);
2765                 if (kid_label && (
2766                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2767                         (flags & SVf_UTF8)
2768                             ? (bytes_cmp_utf8(
2769                                         (const U8*)kid_label, kid_label_len,
2770                                         (const U8*)label, len) == 0)
2771                             : (bytes_cmp_utf8(
2772                                         (const U8*)label, len,
2773                                         (const U8*)kid_label, kid_label_len) == 0)
2774                     : ( len == kid_label_len && ((kid_label == label)
2775                                     || memEQ(kid_label, label, len)))))
2776                     return kid;
2777             }
2778         }
2779         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2780             bool first_kid_of_binary = FALSE;
2781             if (kid == PL_lastgotoprobe)
2782                 continue;
2783             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2784                 if (ops == opstack)
2785                     *ops++ = kid;
2786                 else if (ops[-1] != UNENTERABLE
2787                       && (ops[-1]->op_type == OP_NEXTSTATE ||
2788                           ops[-1]->op_type == OP_DBSTATE))
2789                     ops[-1] = kid;
2790                 else
2791                     *ops++ = kid;
2792             }
2793             if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2794                 first_kid_of_binary = TRUE;
2795                 ops--;
2796             }
2797             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) {
2798                 if (kid->op_type == OP_PUSHDEFER)
2799                     Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block");
2800                 return o;
2801             }
2802             if (first_kid_of_binary)
2803                 *ops++ = UNENTERABLE;
2804         }
2805     }
2806     *ops = 0;
2807     return 0;
2808 }
2809
2810
2811 static void
2812 S_check_op_type(pTHX_ OP * const o)
2813 {
2814     /* Eventually we may want to stack the needed arguments
2815      * for each op.  For now, we punt on the hard ones. */
2816     /* XXX This comment seems to me like wishful thinking.  --sprout */
2817     if (o == UNENTERABLE)
2818         Perl_croak(aTHX_
2819                   "Can't \"goto\" into a binary or list expression");
2820     if (o->op_type == OP_ENTERITER)
2821         Perl_croak(aTHX_
2822                   "Can't \"goto\" into the middle of a foreach loop");
2823     if (o->op_type == OP_ENTERGIVEN)
2824         Perl_croak(aTHX_
2825                   "Can't \"goto\" into a \"given\" block");
2826 }
2827
2828 /* also used for: pp_dump() */
2829
2830 PP(pp_goto)
2831 {
2832     dSP;
2833     OP *retop = NULL;
2834     I32 ix;
2835     PERL_CONTEXT *cx;
2836     OP *enterops[GOTO_DEPTH];
2837     const char *label = NULL;
2838     STRLEN label_len = 0;
2839     U32 label_flags = 0;
2840     const bool do_dump = (PL_op->op_type == OP_DUMP);
2841     static const char* const must_have_label = "goto must have label";
2842
2843     if (PL_op->op_flags & OPf_STACKED) {
2844         /* goto EXPR  or  goto &foo */
2845
2846         SV * const sv = POPs;
2847         SvGETMAGIC(sv);
2848
2849         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2850             /* This egregious kludge implements goto &subroutine */
2851             I32 cxix;
2852             PERL_CONTEXT *cx;
2853             CV *cv = MUTABLE_CV(SvRV(sv));
2854             AV *arg = GvAV(PL_defgv);
2855
2856             while (!CvROOT(cv) && !CvXSUB(cv)) {
2857                 const GV * const gv = CvGV(cv);
2858                 if (gv) {
2859                     GV *autogv;
2860                     SV *tmpstr;
2861                     /* autoloaded stub? */
2862                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2863                         continue;
2864                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2865                                           GvNAMELEN(gv),
2866                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2867                     if (autogv && (cv = GvCV(autogv)))
2868                         continue;
2869                     tmpstr = sv_newmortal();
2870                     gv_efullname3(tmpstr, gv, NULL);
2871                     DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2872                 }
2873                 DIE(aTHX_ "Goto undefined subroutine");
2874             }
2875
2876             cxix = dopopto_cursub();
2877             if (cxix < 0) {
2878                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2879             }
2880             cx  = &cxstack[cxix];
2881             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2882             if (CxTYPE(cx) == CXt_EVAL) {
2883                 if (CxREALEVAL(cx))
2884                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2885                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2886                 else
2887                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2888                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2889             }
2890             else if (CxMULTICALL(cx))
2891                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2892
2893             /* Check for  defer { goto &...; } */
2894             for(ix = cxstack_ix; ix > cxix; ix--) {
2895                 if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
2896                     Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", "goto");
2897             }
2898
2899             /* First do some returnish stuff. */
2900
2901             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2902             FREETMPS;
2903             if (cxix < cxstack_ix) {
2904                 dounwind(cxix);
2905             }
2906             cx = CX_CUR();
2907             cx_topblock(cx);
2908             SPAGAIN;
2909
2910             /* protect @_ during save stack unwind. */
2911             if (arg)
2912                 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2913
2914             assert(PL_scopestack_ix == cx->blk_oldscopesp);
2915             CX_LEAVE_SCOPE(cx);
2916
2917             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2918                 /* this is part of cx_popsub_args() */
2919                 AV* av = MUTABLE_AV(PAD_SVl(0));
2920                 assert(AvARRAY(MUTABLE_AV(
2921                     PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2922                             CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2923
2924                 /* we are going to donate the current @_ from the old sub
2925                  * to the new sub. This first part of the donation puts a
2926                  * new empty AV in the pad[0] slot of the old sub,
2927                  * unless pad[0] and @_ differ (e.g. if the old sub did
2928                  * local *_ = []); in which case clear the old pad[0]
2929                  * array in the usual way */
2930                 if (av == arg || AvREAL(av))
2931                     clear_defarray(av, av == arg);
2932                 else CLEAR_ARGARRAY(av);
2933             }
2934
2935             /* don't restore PL_comppad here. It won't be needed if the
2936              * sub we're going to is non-XS, but restoring it early then
2937              * croaking (e.g. the "Goto undefined subroutine" below)
2938              * means the CX block gets processed again in dounwind,
2939              * but this time with the wrong PL_comppad */
2940
2941             /* A destructor called during LEAVE_SCOPE could have undefined
2942              * our precious cv.  See bug #99850. */
2943             if (!CvROOT(cv) && !CvXSUB(cv)) {
2944                 const GV * const gv = CvGV(cv);
2945                 if (gv) {
2946                     SV * const tmpstr = sv_newmortal();
2947                     gv_efullname3(tmpstr, gv, NULL);
2948                     DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2949                                SVfARG(tmpstr));
2950                 }
2951                 DIE(aTHX_ "Goto undefined subroutine");
2952             }
2953
2954             if (CxTYPE(cx) == CXt_SUB) {
2955                 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2956                 SvREFCNT_dec_NN(cx->blk_sub.cv);
2957             }
2958
2959             /* Now do some callish stuff. */
2960             if (CvISXSUB(cv)) {
2961                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2962                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2963                 SV** mark;
2964
2965                 ENTER;
2966                 SAVETMPS;
2967                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2968
2969                 /* put GvAV(defgv) back onto stack */
2970                 if (items) {
2971                     EXTEND(SP, items+1); /* @_ could have been extended. */
2972                 }
2973                 mark = SP;
2974                 if (items) {
2975                     SSize_t index;
2976                     bool r = cBOOL(AvREAL(arg));
2977                     for (index=0; index<items; index++)
2978                     {
2979                         SV *sv;
2980                         if (m) {
2981                             SV ** const svp = av_fetch(arg, index, 0);
2982                             sv = svp ? *svp : NULL;
2983                         }
2984                         else sv = AvARRAY(arg)[index];
2985                         SP[index+1] = sv
2986                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2987                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2988                     }
2989                 }
2990                 SP += items;
2991                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2992                     /* Restore old @_ */
2993                     CX_POP_SAVEARRAY(cx);
2994                 }
2995
2996                 retop = cx->blk_sub.retop;
2997                 PL_comppad = cx->blk_sub.prevcomppad;
2998                 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2999
3000                 /* XS subs don't have a CXt_SUB, so pop it;
3001                  * this is a cx_popblock(), less all the stuff we already did
3002                  * for cx_topblock() earlier */
3003                 PL_curcop = cx->blk_oldcop;
3004                 /* this is cx_popsub, less all the stuff we already did */
3005                 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
3006
3007                 CX_POP(cx);
3008
3009                 /* Push a mark for the start of arglist */
3010                 PUSHMARK(mark);
3011                 PUTBACK;
3012                 (void)(*CvXSUB(cv))(aTHX_ cv);
3013                 LEAVE;
3014                 goto _return;
3015             }
3016             else {
3017                 PADLIST * const padlist = CvPADLIST(cv);
3018
3019                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3020
3021                 /* partial unrolled cx_pushsub(): */
3022
3023                 cx->blk_sub.cv = cv;
3024                 cx->blk_sub.olddepth = CvDEPTH(cv);
3025
3026                 CvDEPTH(cv)++;
3027                 SvREFCNT_inc_simple_void_NN(cv);
3028                 if (CvDEPTH(cv) > 1) {
3029                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
3030                         sub_crush_depth(cv);
3031                     pad_push(padlist, CvDEPTH(cv));
3032                 }
3033                 PL_curcop = cx->blk_oldcop;
3034                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
3035                 if (CxHASARGS(cx))
3036                 {
3037                     /* second half of donating @_ from the old sub to the
3038                      * new sub: abandon the original pad[0] AV in the
3039                      * new sub, and replace it with the donated @_.
3040                      * pad[0] takes ownership of the extra refcount
3041                      * we gave arg earlier */
3042                     if (arg) {
3043                         SvREFCNT_dec(PAD_SVl(0));
3044                         PAD_SVl(0) = (SV *)arg;
3045                         SvREFCNT_inc_simple_void_NN(arg);
3046                     }
3047
3048                     /* GvAV(PL_defgv) might have been modified on scope
3049                        exit, so point it at arg again. */
3050                     if (arg != GvAV(PL_defgv)) {
3051                         AV * const av = GvAV(PL_defgv);
3052                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3053                         SvREFCNT_dec(av);
3054                     }
3055                 }
3056
3057                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
3058                     Perl_get_db_sub(aTHX_ NULL, cv);
3059                     if (PERLDB_GOTO) {
3060                         CV * const gotocv = get_cvs("DB::goto", 0);
3061                         if (gotocv) {
3062                             PUSHMARK( PL_stack_sp );
3063                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3064                             PL_stack_sp--;
3065                         }
3066                     }
3067                 }
3068                 retop = CvSTART(cv);
3069                 goto putback_return;
3070             }
3071         }
3072         else {
3073             /* goto EXPR */
3074             label       = SvPV_nomg_const(sv, label_len);
3075             label_flags = SvUTF8(sv);
3076         }
3077     }
3078     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3079         /* goto LABEL  or  dump LABEL */
3080         label       = cPVOP->op_pv;
3081         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3082         label_len   = strlen(label);
3083     }
3084     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3085
3086     PERL_ASYNC_CHECK();
3087
3088     if (label_len) {
3089         OP *gotoprobe = NULL;
3090         bool leaving_eval = FALSE;
3091         bool in_block = FALSE;
3092         bool pseudo_block = FALSE;
3093         PERL_CONTEXT *last_eval_cx = NULL;
3094
3095         /* find label */
3096
3097         PL_lastgotoprobe = NULL;
3098         *enterops = 0;
3099         for (ix = cxstack_ix; ix >= 0; ix--) {
3100             cx = &cxstack[ix];
3101             switch (CxTYPE(cx)) {
3102             case CXt_EVAL:
3103                 leaving_eval = TRUE;
3104                 if (!CxEVALBLOCK(cx)) {
3105                     gotoprobe = (last_eval_cx ?
3106                                 last_eval_cx->blk_eval.old_eval_root :
3107                                 PL_eval_root);
3108                     last_eval_cx = cx;
3109                     break;
3110                 }
3111                 /* else fall through */
3112             case CXt_LOOP_PLAIN:
3113             case CXt_LOOP_LAZYIV:
3114             case CXt_LOOP_LAZYSV:
3115             case CXt_LOOP_LIST:
3116             case CXt_LOOP_ARY:
3117             case CXt_GIVEN:
3118             case CXt_WHEN:
3119                 gotoprobe = OpSIBLING(cx->blk_oldcop);
3120                 break;
3121             case CXt_SUBST:
3122                 continue;
3123             case CXt_BLOCK:
3124                 if (ix) {
3125                     gotoprobe = OpSIBLING(cx->blk_oldcop);
3126                     in_block = TRUE;
3127                 } else
3128                     gotoprobe = PL_main_root;
3129                 break;
3130             case CXt_SUB:
3131                 gotoprobe = CvROOT(cx->blk_sub.cv);
3132                 pseudo_block = cBOOL(CxMULTICALL(cx));
3133                 break;
3134             case CXt_FORMAT:
3135             case CXt_NULL:
3136                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3137             case CXt_DEFER:
3138                 DIE(aTHX_ "Can't \"%s\" out of a \"defer\" block", "goto");
3139             default:
3140                 if (ix)
3141                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3142                         CxTYPE(cx), (long) ix);
3143                 gotoprobe = PL_main_root;
3144                 break;
3145             }
3146             if (gotoprobe) {
3147                 OP *sibl1, *sibl2;
3148
3149                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3150                                     enterops, enterops + GOTO_DEPTH);
3151                 if (retop)
3152                     break;
3153                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3154                      sibl1->op_type == OP_UNSTACK &&
3155                      (sibl2 = OpSIBLING(sibl1)))
3156                 {
3157                     retop = dofindlabel(sibl2,
3158                                         label, label_len, label_flags, enterops,
3159                                         enterops + GOTO_DEPTH);
3160                     if (retop)
3161                         break;
3162                 }
3163             }
3164             if (pseudo_block)
3165                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3166             PL_lastgotoprobe = gotoprobe;
3167         }
3168         if (!retop)
3169             DIE(aTHX_ "Can't find label %" UTF8f,
3170                        UTF8fARG(label_flags, label_len, label));
3171
3172         /* if we're leaving an eval, check before we pop any frames
3173            that we're not going to punt, otherwise the error
3174            won't be caught */
3175
3176         if (leaving_eval && *enterops && enterops[1]) {
3177             I32 i;
3178             for (i = 1; enterops[i]; i++)
3179                 S_check_op_type(aTHX_ enterops[i]);
3180         }
3181
3182         if (*enterops && enterops[1]) {
3183             I32 i = enterops[1] != UNENTERABLE
3184                  && enterops[1]->op_type == OP_ENTER && in_block
3185                     ? 2
3186                     : 1;
3187             if (enterops[i])
3188                 deprecate("\"goto\" to jump into a construct");
3189         }
3190
3191         /* pop unwanted frames */
3192
3193         if (ix < cxstack_ix) {
3194             if (ix < 0)
3195                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3196             dounwind(ix);
3197             cx = CX_CUR();
3198             cx_topblock(cx);
3199         }
3200
3201         /* push wanted frames */
3202
3203         if (*enterops && enterops[1]) {
3204             OP * const oldop = PL_op;
3205             ix = enterops[1] != UNENTERABLE
3206               && enterops[1]->op_type == OP_ENTER && in_block
3207                    ? 2
3208                    : 1;
3209             for (; enterops[ix]; ix++) {
3210                 PL_op = enterops[ix];
3211                 S_check_op_type(aTHX_ PL_op);
3212                 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3213                                          OP_NAME(PL_op)));
3214                 PL_op->op_ppaddr(aTHX);
3215             }
3216             PL_op = oldop;
3217         }
3218     }
3219
3220     if (do_dump) {
3221 #ifdef VMS
3222         if (!retop) retop = PL_main_start;
3223 #endif
3224         PL_restartop = retop;
3225         PL_do_undump = TRUE;
3226
3227         my_unexec();
3228
3229         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3230         PL_do_undump = FALSE;
3231     }
3232
3233     putback_return:
3234     PL_stack_sp = sp;
3235     _return:
3236     PERL_ASYNC_CHECK();
3237     return retop;
3238 }
3239
3240 PP(pp_exit)
3241 {
3242     dSP;
3243     I32 anum;
3244
3245     if (MAXARG < 1)
3246         anum = 0;
3247     else if (!TOPs) {
3248         anum = 0; (void)POPs;
3249     }
3250     else {
3251         anum = SvIVx(POPs);
3252 #ifdef VMS
3253         if (anum == 1
3254          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3255             anum = 0;
3256         VMSISH_HUSHED  =
3257             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3258 #endif
3259     }
3260     PL_exit_flags |= PERL_EXIT_EXPECTED;
3261     my_exit(anum);
3262     PUSHs(&PL_sv_undef);
3263     RETURN;
3264 }
3265
3266 /* Eval. */
3267
3268 STATIC void
3269 S_save_lines(pTHX_ AV *array, SV *sv)
3270 {
3271     const char *s = SvPVX_const(sv);
3272     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3273     I32 line = 1;
3274
3275     PERL_ARGS_ASSERT_SAVE_LINES;
3276
3277     while (s && s < send) {
3278         const char *t;
3279         SV * const tmpstr = newSV_type(SVt_PVMG);
3280
3281         t = (const char *)memchr(s, '\n', send - s);
3282         if (t)
3283             t++;
3284         else
3285             t = send;
3286
3287         sv_setpvn(tmpstr, s, t - s);
3288         av_store(array, line++, tmpstr);
3289         s = t;
3290     }
3291 }
3292
3293 /*
3294 =for apidoc docatch
3295
3296 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3297
3298 0 is used as continue inside eval,
3299
3300 3 is used for a die caught by an inner eval - continue inner loop
3301
3302 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3303 establish a local jmpenv to handle exception traps.
3304
3305 =cut
3306 */
3307 STATIC OP *
3308 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3309 {
3310     int ret;
3311     OP * const oldop = PL_op;
3312     dJMPENV;
3313
3314     assert(CATCH_GET == TRUE);
3315
3316     JMPENV_PUSH(ret);
3317     switch (ret) {
3318     case 0:
3319         PL_op = firstpp(aTHX);
3320  redo_body:
3321         CALLRUNOPS(aTHX);
3322         break;
3323     case 3:
3324         /* die caught by an inner eval - continue inner loop */
3325         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3326             PL_restartjmpenv = NULL;
3327             PL_op = PL_restartop;
3328             PL_restartop = 0;
3329             goto redo_body;
3330         }
3331         /* FALLTHROUGH */
3332     default:
3333         JMPENV_POP;
3334         PL_op = oldop;
3335         JMPENV_JUMP(ret);
3336         NOT_REACHED; /* NOTREACHED */
3337     }
3338     JMPENV_POP;
3339     PL_op = oldop;
3340     return NULL;
3341 }
3342
3343
3344 /*
3345 =for apidoc find_runcv
3346
3347 Locate the CV corresponding to the currently executing sub or eval.
3348 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3349 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3350 entered.  (This allows debuggers to eval in the scope of the breakpoint
3351 rather than in the scope of the debugger itself.)
3352
3353 =cut
3354 */
3355
3356 CV*
3357 Perl_find_runcv(pTHX_ U32 *db_seqp)
3358 {
3359     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3360 }
3361
3362 /* If this becomes part of the API, it might need a better name. */
3363 CV *
3364 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3365 {
3366     PERL_SI      *si;
3367     int          level = 0;
3368
3369     if (db_seqp)
3370         *db_seqp =
3371             PL_curcop == &PL_compiling
3372                 ? PL_cop_seqmax
3373                 : PL_curcop->cop_seq;
3374
3375     for (si = PL_curstackinfo; si; si = si->si_prev) {
3376         I32 ix;
3377         for (ix = si->si_cxix; ix >= 0; ix--) {
3378             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3379             CV *cv = NULL;
3380             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3381                 cv = cx->blk_sub.cv;
3382                 /* skip DB:: code */
3383                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3384                     *db_seqp = cx->blk_oldcop->cop_seq;
3385                     continue;
3386                 }
3387                 if (cx->cx_type & CXp_SUB_RE)
3388                     continue;
3389             }
3390             else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3391                 cv = cx->blk_eval.cv;
3392             if (cv) {
3393                 switch (cond) {
3394                 case FIND_RUNCV_padid_eq:
3395                     if (!CvPADLIST(cv)
3396                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3397                         continue;
3398                     return cv;
3399                 case FIND_RUNCV_level_eq:
3400                     if (level++ != arg) continue;
3401                     /* FALLTHROUGH */
3402                 default:
3403                     return cv;
3404                 }
3405             }
3406         }
3407     }
3408     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3409 }
3410
3411
3412 /* Run yyparse() in a setjmp wrapper. Returns:
3413  *   0: yyparse() successful
3414  *   1: yyparse() failed
3415  *   3: yyparse() died
3416  */
3417 STATIC int
3418 S_try_yyparse(pTHX_ int gramtype)
3419 {
3420     int ret;
3421     dJMPENV;
3422
3423     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3424     JMPENV_PUSH(ret);
3425     switch (ret) {
3426     case 0:
3427         ret = yyparse(gramtype) ? 1 : 0;
3428         break;
3429     case 3:
3430         break;
3431     default:
3432         JMPENV_POP;
3433         JMPENV_JUMP(ret);
3434         NOT_REACHED; /* NOTREACHED */
3435     }
3436     JMPENV_POP;
3437     return ret;
3438 }
3439
3440
3441 /* Compile a require/do or an eval ''.
3442  *
3443  * outside is the lexically enclosing CV (if any) that invoked us.
3444  * seq     is the current COP scope value.
3445  * hh      is the saved hints hash, if any.
3446  *
3447  * Returns a bool indicating whether the compile was successful; if so,
3448  * PL_eval_start contains the first op of the compiled code; otherwise,
3449  * pushes undef.
3450  *
3451  * This function is called from two places: pp_require and pp_entereval.
3452  * These can be distinguished by whether PL_op is entereval.
3453  */
3454
3455 STATIC bool
3456 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3457 {
3458     dSP;
3459     OP * const saveop = PL_op;
3460     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3461     COP * const oldcurcop = PL_curcop;
3462     bool in_require = (saveop->op_type == OP_REQUIRE);
3463     int yystatus;
3464     CV *evalcv;
3465
3466     PL_in_eval = (in_require
3467                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3468                   : (EVAL_INEVAL |
3469                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3470                             ? EVAL_RE_REPARSING : 0)));
3471
3472     PUSHMARK(SP);
3473
3474     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3475     CvEVAL_on(evalcv);
3476     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3477     CX_CUR()->blk_eval.cv = evalcv;
3478     CX_CUR()->blk_gimme = gimme;
3479
3480     CvOUTSIDE_SEQ(evalcv) = seq;
3481     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3482
3483     /* set up a scratch pad */
3484
3485     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3486     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3487
3488
3489     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3490
3491     /* make sure we compile in the right package */
3492
3493     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3494         SAVEGENERICSV(PL_curstash);
3495         PL_curstash = (HV *)CopSTASH(PL_curcop);
3496         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3497         else {
3498             SvREFCNT_inc_simple_void(PL_curstash);
3499             save_item(PL_curstname);
3500             sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3501         }
3502     }
3503     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3504     SAVESPTR(PL_beginav);
3505     PL_beginav = newAV();
3506     SAVEFREESV(PL_beginav);
3507     SAVESPTR(PL_unitcheckav);
3508     PL_unitcheckav = newAV();
3509     SAVEFREESV(PL_unitcheckav);
3510
3511
3512     ENTER_with_name("evalcomp");
3513     SAVESPTR(PL_compcv);
3514     PL_compcv = evalcv;
3515
3516     /* try to compile it */
3517
3518     PL_eval_root = NULL;
3519     PL_curcop = &PL_compiling;
3520     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3521         PL_in_eval |= EVAL_KEEPERR;
3522     else
3523         CLEAR_ERRSV();
3524
3525     SAVEHINTS();
3526     if (clear_hints) {
3527         PL_hints = HINTS_DEFAULT;
3528         hv_clear(GvHV(PL_hintgv));
3529         CLEARFEATUREBITS();
3530     }
3531     else {
3532         PL_hints = saveop->op_private & OPpEVAL_COPHH
3533                      ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3534
3535         /* making 'use re eval' not be in scope when compiling the
3536          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3537          * infinite recursion when S_has_runtime_code() gives a false
3538          * positive: the second time round, HINT_RE_EVAL isn't set so we
3539          * don't bother calling S_has_runtime_code() */
3540         if (PL_in_eval & EVAL_RE_REPARSING)
3541             PL_hints &= ~HINT_RE_EVAL;
3542
3543         if (hh) {
3544             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3545             SvREFCNT_dec(GvHV(PL_hintgv));
3546             GvHV(PL_hintgv) = hh;
3547             FETCHFEATUREBITSHH(hh);
3548         }
3549     }
3550     SAVECOMPILEWARNINGS();
3551     if (clear_hints) {
3552         if (PL_dowarn & G_WARN_ALL_ON)
3553             PL_compiling.cop_warnings = pWARN_ALL ;
3554         else if (PL_dowarn & G_WARN_ALL_OFF)
3555             PL_compiling.cop_warnings = pWARN_NONE ;
3556         else
3557             PL_compiling.cop_warnings = pWARN_STD ;
3558     }
3559     else {
3560         PL_compiling.cop_warnings =
3561             DUP_WARNINGS(oldcurcop->cop_warnings);
3562         cophh_free(CopHINTHASH_get(&PL_compiling));
3563         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3564             /* The label, if present, is the first entry on the chain. So rather
3565                than writing a blank label in front of it (which involves an
3566                allocation), just use the next entry in the chain.  */
3567             PL_compiling.cop_hints_hash
3568                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3569             /* Check the assumption that this removed the label.  */
3570             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3571         }
3572         else
3573             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3574     }
3575
3576     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3577
3578     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3579      * so honour CATCH_GET and trap it here if necessary */
3580
3581
3582     /* compile the code */
3583     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3584
3585     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3586         PERL_CONTEXT *cx;
3587         SV *errsv;
3588
3589         PL_op = saveop;
3590         /* note that if yystatus == 3, then the require/eval died during
3591          * compilation, so the EVAL CX block has already been popped, and
3592          * various vars restored */
3593         if (yystatus != 3) {
3594             if (PL_eval_root) {
3595                 op_free(PL_eval_root);
3596                 PL_eval_root = NULL;
3597             }
3598             SP = PL_stack_base + POPMARK;       /* pop original mark */
3599             cx = CX_CUR();
3600             assert(CxTYPE(cx) == CXt_EVAL);
3601             /* pop the CXt_EVAL, and if was a require, croak */
3602             S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3603         }
3604
3605         /* die_unwind() re-croaks when in require, having popped the
3606          * require EVAL context. So we should never catch a require
3607          * exception here */
3608         assert(!in_require);
3609
3610         errsv = ERRSV;
3611         if (!*(SvPV_nolen_const(errsv)))
3612             sv_setpvs(errsv, "Compilation error");
3613
3614         if (gimme != G_LIST) PUSHs(&PL_sv_undef);
3615         PUTBACK;
3616         return FALSE;
3617     }
3618
3619     /* Compilation successful. Now clean up */
3620
3621     LEAVE_with_name("evalcomp");
3622
3623     CopLINE_set(&PL_compiling, 0);
3624     SAVEFREEOP(PL_eval_root);
3625     cv_forget_slab(evalcv);
3626
3627     DEBUG_x(dump_eval());
3628
3629     /* Register with debugger: */
3630     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3631         CV * const cv = get_cvs("DB::postponed", 0);
3632         if (cv) {
3633             dSP;
3634             PUSHMARK(SP);
3635             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3636             PUTBACK;
3637             call_sv(MUTABLE_SV(cv), G_DISCARD);
3638         }
3639     }
3640
3641     if (PL_unitcheckav) {
3642         OP *es = PL_eval_start;
3643         call_list(PL_scopestack_ix, PL_unitcheckav);
3644         PL_eval_start = es;
3645     }
3646
3647     CvDEPTH(evalcv) = 1;
3648     SP = PL_stack_base + POPMARK;               /* pop original mark */
3649     PL_op = saveop;                     /* The caller may need it. */
3650     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3651
3652     PUTBACK;
3653     return TRUE;
3654 }
3655
3656 /* Return NULL if the file doesn't exist or isn't a file;
3657  * else return PerlIO_openn().
3658  */
3659
3660 STATIC PerlIO *
3661 S_check_type_and_open(pTHX_ SV *name)
3662 {
3663     Stat_t st;
3664     STRLEN len;
3665     PerlIO * retio;
3666     const char *p = SvPV_const(name, len);
3667     int st_rc;
3668
3669     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3670
3671     /* checking here captures a reasonable error message when
3672      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3673      * user gets a confusing message about looking for the .pmc file
3674      * rather than for the .pm file so do the check in S_doopen_pm when
3675      * PMC is on instead of here. S_doopen_pm calls this func.
3676      * This check prevents a \0 in @INC causing problems.
3677      */
3678 #ifdef PERL_DISABLE_PMC
3679     if (!IS_SAFE_PATHNAME(p, len, "require"))
3680         return NULL;
3681 #endif
3682
3683     /* on Win32 stat is expensive (it does an open() and close() twice and
3684        a couple other IO calls), the open will fail with a dir on its own with
3685        errno EACCES, so only do a stat to separate a dir from a real EACCES
3686        caused by user perms */
3687 #ifndef WIN32
3688     st_rc = PerlLIO_stat(p, &st);
3689
3690     if (st_rc < 0)
3691         return NULL;
3692     else {
3693         int eno;
3694         if(S_ISBLK(st.st_mode)) {
3695             eno = EINVAL;
3696             goto not_file;
3697         }
3698         else if(S_ISDIR(st.st_mode)) {
3699             eno = EISDIR;
3700             not_file:
3701             errno = eno;
3702             return NULL;
3703         }
3704     }
3705 #endif
3706
3707     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3708 #ifdef WIN32
3709     /* EACCES stops the INC search early in pp_require to implement
3710        feature RT #113422 */
3711     if(!retio && errno == EACCES) { /* exists but probably a directory */
3712         int eno;
3713         st_rc = PerlLIO_stat(p, &st);
3714         if (st_rc >= 0) {
3715             if(S_ISDIR(st.st_mode))
3716                 eno = EISDIR;
3717             else if(S_ISBLK(st.st_mode))
3718                 eno = EINVAL;
3719             else
3720                 eno = EACCES;
3721             errno = eno;
3722         }
3723     }
3724 #endif
3725     return retio;
3726 }
3727
3728 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3729  * but first check for bad names (\0) and non-files.
3730  * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3731  * try loading Foo.pmc first.
3732  */
3733 #ifndef PERL_DISABLE_PMC
3734 STATIC PerlIO *
3735 S_doopen_pm(pTHX_ SV *name)
3736 {
3737     STRLEN namelen;
3738     const char *p = SvPV_const(name, namelen);
3739
3740     PERL_ARGS_ASSERT_DOOPEN_PM;
3741
3742     /* check the name before trying for the .pmc name to avoid the
3743      * warning referring to the .pmc which the user probably doesn't
3744      * know or care about
3745      */
3746     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3747         return NULL;
3748
3749     if (memENDPs(p, namelen, ".pm")) {
3750         SV *const pmcsv = sv_newmortal();
3751         PerlIO * pmcio;
3752
3753         SvSetSV_nosteal(pmcsv,name);
3754         sv_catpvs(pmcsv, "c");
3755
3756         pmcio = check_type_and_open(pmcsv);
3757         if (pmcio)
3758             return pmcio;
3759     }
3760     return check_type_and_open(name);
3761 }
3762 #else
3763 #  define doopen_pm(name) check_type_and_open(name)
3764 #endif /* !PERL_DISABLE_PMC */
3765
3766 /* require doesn't search in @INC for absolute names, or when the name is
3767    explicitly relative the current directory: i.e. ./, ../ */
3768 PERL_STATIC_INLINE bool
3769 S_path_is_searchable(const char *name)
3770 {
3771     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3772
3773     if (PERL_FILE_IS_ABSOLUTE(name)
3774 #ifdef WIN32
3775         || (*name == '.' && ((name[1] == '/' ||
3776                              (name[1] == '.' && name[2] == '/'))
3777                          || (name[1] == '\\' ||
3778                              ( name[1] == '.' && name[2] == '\\')))
3779             )
3780 #else
3781         || (*name == '.' && (name[1] == '/' ||
3782                              (name[1] == '.' && name[2] == '/')))
3783 #endif
3784          )
3785     {
3786         return FALSE;
3787     }
3788     else
3789         return TRUE;
3790 }
3791
3792
3793 /* implement 'require 5.010001' */
3794
3795 static OP *
3796 S_require_version(pTHX_ SV *sv)
3797 {
3798     dSP;
3799
3800     sv = sv_2mortal(new_version(sv));
3801     if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3802         upg_version(PL_patchlevel, TRUE);
3803     if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3804         if ( vcmp(sv,PL_patchlevel) <= 0 )
3805             DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3806                 SVfARG(sv_2mortal(vnormal(sv))),
3807                 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3808             );
3809     }
3810     else {
3811         if ( vcmp(sv,PL_patchlevel) > 0 ) {
3812             I32 first = 0;
3813             AV *lav;
3814             SV * const req = SvRV(sv);
3815             SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3816
3817             /* get the left hand term */
3818             lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3819
3820             first  = SvIV(*av_fetch(lav,0,0));
3821             if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3822                 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3823                 || av_count(lav) > 2             /* FP with > 3 digits */
3824                 || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3825                ) {
3826                 DIE(aTHX_ "Perl %" SVf " required--this is only "
3827                     "%" SVf ", stopped",
3828                     SVfARG(sv_2mortal(vnormal(req))),
3829                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3830                 );
3831             }
3832             else { /* probably 'use 5.10' or 'use 5.8' */
3833                 SV *hintsv;
3834                 I32 second = 0;
3835
3836                 if (av_count(lav) > 1)
3837                     second = SvIV(*av_fetch(lav,1,0));
3838
3839                 second /= second >= 600  ? 100 : 10;
3840                 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3841                                        (int)first, (int)second);
3842                 upg_version(hintsv, TRUE);
3843
3844                 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3845                     "--this is only %" SVf ", stopped",
3846                     SVfARG(sv_2mortal(vnormal(req))),
3847                     SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3848                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3849                 );
3850             }
3851         }
3852     }
3853
3854     RETPUSHYES;
3855 }
3856
3857 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3858  * The first form will have already been converted at compile time to
3859  * the second form */
3860
3861 static OP *
3862 S_require_file(pTHX_ SV *sv)
3863 {
3864     dSP;
3865
3866     PERL_CONTEXT *cx;
3867     const char *name;
3868     STRLEN len;
3869     char * unixname;
3870     STRLEN unixlen;
3871 #ifdef VMS
3872     int vms_unixname = 0;
3873     char *unixdir;
3874 #endif
3875     /* tryname is the actual pathname (with @INC prefix) which was loaded.
3876      * It's stored as a value in %INC, and used for error messages */
3877     const char *tryname = NULL;
3878     SV *namesv = NULL; /* SV equivalent of tryname */
3879     const U8 gimme = GIMME_V;
3880     int filter_has_file = 0;
3881     PerlIO *tryrsfp = NULL;
3882     SV *filter_cache = NULL;
3883     SV *filter_state = NULL;
3884     SV *filter_sub = NULL;
3885     SV *hook_sv = NULL;
3886     OP *op;
3887     int saved_errno;
3888     bool path_searchable;
3889     I32 old_savestack_ix;
3890     const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3891     const char *const op_name = op_is_require ? "require" : "do";
3892     SV ** svp_cached = NULL;
3893
3894     assert(op_is_require || PL_op->op_type == OP_DOFILE);
3895
3896     if (!SvOK(sv))
3897         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3898     name = SvPV_nomg_const(sv, len);
3899     if (!(name && len > 0 && *name))
3900         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3901
3902 #ifndef VMS
3903         /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3904         if (op_is_require) {
3905                 /* can optimize to only perform one single lookup */
3906                 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3907                 if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES;
3908         }
3909 #endif
3910
3911     if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3912         if (!op_is_require) {
3913             CLEAR_ERRSV();
3914             RETPUSHUNDEF;
3915         }
3916         DIE(aTHX_ "Can't locate %s:   %s",
3917             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3918                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3919             Strerror(ENOENT));
3920     }
3921     TAINT_PROPER(op_name);
3922
3923     path_searchable = path_is_searchable(name);
3924
3925 #ifdef VMS
3926     /* The key in the %ENV hash is in the syntax of file passed as the argument
3927      * usually this is in UNIX format, but sometimes in VMS format, which
3928      * can result in a module being pulled in more than once.
3929      * To prevent this, the key must be stored in UNIX format if the VMS
3930      * name can be translated to UNIX.
3931      */
3932
3933     if ((unixname =
3934           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3935          != NULL) {
3936         unixlen = strlen(unixname);
3937         vms_unixname = 1;
3938     }
3939     else
3940 #endif
3941     {
3942         /* if not VMS or VMS name can not be translated to UNIX, pass it
3943          * through.
3944          */
3945         unixname = (char *) name;
3946         unixlen = len;
3947     }
3948     if (op_is_require) {
3949         /* reuse the previous hv_fetch result if possible */
3950         SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3951         if ( svp ) {
3952             /* we already did a get magic if this was cached */
3953             if (!svp_cached)
3954                 SvGETMAGIC(*svp);
3955             if (SvOK(*svp))
3956                 RETPUSHYES;
3957             else
3958                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3959                             "Compilation failed in require", unixname);
3960         }
3961
3962         /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3963         if (PL_op->op_flags & OPf_KIDS) {
3964             SVOP * const kid = (SVOP*)cUNOP->op_first;
3965
3966             if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3967                 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3968                  * doesn't map to a naughty pathname like /Foo/Bar.pm.
3969                  * Note that the parser will normally detect such errors
3970                  * at compile time before we reach here, but
3971                  * Perl_load_module() can fake up an identical optree
3972                  * without going near the parser, and being able to put
3973                  * anything as the bareword. So we include a duplicate set
3974                  * of checks here at runtime.
3975                  */
3976                 const STRLEN package_len = len - 3;
3977                 const char slashdot[2] = {'/', '.'};
3978 #ifdef DOSISH
3979                 const char backslashdot[2] = {'\\', '.'};
3980 #endif
3981
3982                 /* Disallow *purported* barewords that map to absolute
3983                    filenames, filenames relative to the current or parent
3984                    directory, or (*nix) hidden filenames.  Also sanity check
3985                    that the generated filename ends .pm  */
3986                 if (!path_searchable || len < 3 || name[0] == '.'
3987                     || !memEQs(name + package_len, len - package_len, ".pm"))
3988                     DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3989                 if (memchr(name, 0, package_len)) {
3990                     /* diag_listed_as: Bareword in require contains "%s" */
3991                     DIE(aTHX_ "Bareword in require contains \"\\0\"");
3992                 }
3993                 if (ninstr(name, name + package_len, slashdot,
3994                            slashdot + sizeof(slashdot))) {
3995                     /* diag_listed_as: Bareword in require contains "%s" */
3996                     DIE(aTHX_ "Bareword in require contains \"/.\"");
3997                 }
3998 #ifdef DOSISH
3999                 if (ninstr(name, name + package_len, backslashdot,
4000                            backslashdot + sizeof(backslashdot))) {
4001                     /* diag_listed_as: Bareword in require contains "%s" */
4002                     DIE(aTHX_ "Bareword in require contains \"\\.\"");
4003                 }
4004 #endif
4005             }
4006         }
4007     }
4008
4009     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
4010
4011     /* Try to locate and open a file, possibly using @INC  */
4012
4013     /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
4014      * the file directly rather than via @INC ... */
4015     if (!path_searchable) {
4016         /* At this point, name is SvPVX(sv)  */
4017         tryname = name;
4018         tryrsfp = doopen_pm(sv);
4019     }
4020
4021     /* ... but if we fail, still search @INC for code references;
4022      * these are applied even on non-searchable paths (except
4023      * if we got EACESS).
4024      *
4025      * For searchable paths, just search @INC normally
4026      */
4027     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
4028         AV * const ar = GvAVn(PL_incgv);
4029         SSize_t i;
4030 #ifdef VMS
4031         if (vms_unixname)
4032 #endif
4033         {
4034             SV *nsv = sv;
4035             namesv = newSV_type(SVt_PV);
4036             for (i = 0; i <= AvFILL(ar); i++) {
4037                 SV * const dirsv = *av_fetch(ar, i, TRUE);
4038
4039                 SvGETMAGIC(dirsv);
4040                 if (SvROK(dirsv)) {
4041                     int count;
4042                     SV **svp;
4043                     SV *loader = dirsv;
4044
4045                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
4046                         && !SvOBJECT(SvRV(loader)))
4047                     {
4048                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4049                         SvGETMAGIC(loader);
4050                     }
4051
4052                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4053                                    PTR2UV(SvRV(dirsv)), name);
4054                     tryname = SvPVX_const(namesv);
4055                     tryrsfp = NULL;
4056
4057                     if (SvPADTMP(nsv)) {
4058                         nsv = sv_newmortal();
4059                         SvSetSV_nosteal(nsv,sv);
4060                     }
4061
4062                     ENTER_with_name("call_INC");
4063                     SAVETMPS;
4064                     EXTEND(SP, 2);
4065
4066                     PUSHMARK(SP);
4067                     PUSHs(dirsv);
4068                     PUSHs(nsv);
4069                     PUTBACK;
4070                     if (SvGMAGICAL(loader)) {
4071                         SV *l = sv_newmortal();
4072                         sv_setsv_nomg(l, loader);
4073                         loader = l;
4074                     }
4075                     if (sv_isobject(loader))
4076                         count = call_method("INC", G_LIST);
4077                     else
4078                         count = call_sv(loader, G_LIST);
4079                     SPAGAIN;
4080
4081                     if (count > 0) {
4082                         int i = 0;
4083                         SV *arg;
4084
4085                         SP -= count - 1;
4086                         arg = SP[i++];
4087
4088                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4089                             && !isGV_with_GP(SvRV(arg))) {
4090                             filter_cache = SvRV(arg);
4091
4092                             if (i < count) {
4093                                 arg = SP[i++];
4094                             }
4095                         }
4096
4097                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4098                             arg = SvRV(arg);
4099                         }
4100
4101                         if (isGV_with_GP(arg)) {
4102                             IO * const io = GvIO((const GV *)arg);
4103
4104                             ++filter_has_file;
4105
4106                             if (io) {
4107                                 tryrsfp = IoIFP(io);
4108                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4109                                     PerlIO_close(IoOFP(io));
4110                                 }
4111                                 IoIFP(io) = NULL;
4112                                 IoOFP(io) = NULL;
4113                             }
4114
4115                             if (i < count) {
4116                                 arg = SP[i++];
4117                             }
4118                         }
4119
4120                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4121                             filter_sub = arg;
4122                             SvREFCNT_inc_simple_void_NN(filter_sub);
4123
4124                             if (i < count) {
4125                                 filter_state = SP[i];
4126                                 SvREFCNT_inc_simple_void(filter_state);
4127                             }
4128                         }
4129
4130                         if (!tryrsfp && (filter_cache || filter_sub)) {
4131                             tryrsfp = PerlIO_open(BIT_BUCKET,
4132                                                   PERL_SCRIPT_MODE);
4133                         }
4134                         SP--;
4135                     }
4136
4137                     /* FREETMPS may free our filter_cache */
4138                     SvREFCNT_inc_simple_void(filter_cache);
4139
4140                     PUTBACK;
4141                     FREETMPS;
4142                     LEAVE_with_name("call_INC");
4143
4144                     /* Now re-mortalize it. */
4145                     sv_2mortal(filter_cache);
4146
4147                     /* Adjust file name if the hook has set an %INC entry.
4148                        This needs to happen after the FREETMPS above.  */
4149                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4150                     if (svp)
4151                         tryname = SvPV_nolen_const(*svp);
4152
4153                     if (tryrsfp) {
4154                         hook_sv = dirsv;
4155                         break;
4156                     }
4157
4158                     filter_has_file = 0;
4159                     filter_cache = NULL;
4160                     if (filter_state) {
4161                         SvREFCNT_dec_NN(filter_state);
4162                         filter_state = NULL;
4163                     }
4164                     if (filter_sub) {
4165                         SvREFCNT_dec_NN(filter_sub);
4166                         filter_sub = NULL;
4167                     }
4168                 }
4169                 else if (path_searchable) {
4170                     /* match against a plain @INC element (non-searchable
4171                      * paths are only matched against refs in @INC) */
4172                     const char *dir;
4173                     STRLEN dirlen;
4174
4175                     if (SvOK(dirsv)) {
4176                         dir = SvPV_nomg_const(dirsv, dirlen);
4177                     } else {
4178                         dir = "";
4179                         dirlen = 0;
4180                     }
4181
4182                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4183                         continue;
4184 #ifdef VMS
4185                     if ((unixdir =
4186                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4187                          == NULL)
4188                         continue;
4189                     sv_setpv(namesv, unixdir);
4190                     sv_catpv(namesv, unixname);
4191 #else
4192                     /* The equivalent of
4193                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4194                        but without the need to parse the format string, or
4195                        call strlen on either pointer, and with the correct
4196                        allocation up front.  */
4197                     {
4198                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4199
4200                         memcpy(tmp, dir, dirlen);
4201                         tmp +=dirlen;
4202
4203                         /* Avoid '<dir>//<file>' */
4204                         if (!dirlen || *(tmp-1) != '/') {
4205                             *tmp++ = '/';
4206                         } else {
4207                             /* So SvCUR_set reports the correct length below */
4208                             dirlen--;
4209                         }
4210
4211                         /* name came from an SV, so it will have a '\0' at the
4212                            end that we can copy as part of this memcpy().  */
4213                         memcpy(tmp, name, len + 1);
4214
4215                         SvCUR_set(namesv, dirlen + len + 1);
4216                         SvPOK_on(namesv);
4217                     }
4218 #endif
4219                     TAINT_PROPER(op_name);
4220                     tryname = SvPVX_const(namesv);
4221                     tryrsfp = doopen_pm(namesv);
4222                     if (tryrsfp) {
4223                         if (tryname[0] == '.' && tryname[1] == '/') {
4224                             ++tryname;
4225                             while (*++tryname == '/') {}
4226                         }
4227                         break;
4228                     }
4229                     else if (errno == EMFILE || errno == EACCES) {
4230                         /* no point in trying other paths if out of handles;
4231                          * on the other hand, if we couldn't open one of the
4232                          * files, then going on with the search could lead to
4233                          * unexpected results; see perl #113422
4234                          */
4235                         break;
4236                     }
4237                 }
4238             }
4239         }
4240     }
4241
4242     /* at this point we've ether opened a file (tryrsfp) or set errno */
4243
4244     saved_errno = errno; /* sv_2mortal can realloc things */
4245     sv_2mortal(namesv);
4246     if (!tryrsfp) {
4247         /* we failed; croak if require() or return undef if do() */
4248         if (op_is_require) {
4249             if(saved_errno == EMFILE || saved_errno == EACCES) {
4250                 /* diag_listed_as: Can't locate %s */
4251                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4252                     name, tryname, Strerror(saved_errno));
4253             } else {
4254                 if (path_searchable) {          /* did we lookup @INC? */
4255                     AV * const ar = GvAVn(PL_incgv);
4256                     SSize_t i;
4257                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4258                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4259                     for (i = 0; i <= AvFILL(ar); i++) {
4260                         sv_catpvs(inc, " ");
4261                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4262                     }
4263                     if (memENDPs(name, len, ".pm")) {
4264                         const char *e = name + len - (sizeof(".pm") - 1);
4265                         const char *c;
4266                         bool utf8 = cBOOL(SvUTF8(sv));
4267
4268                         /* if the filename, when converted from "Foo/Bar.pm"
4269                          * form back to Foo::Bar form, makes a valid
4270                          * package name (i.e. parseable by C<require
4271                          * Foo::Bar>), then emit a hint.
4272                          *
4273                          * this loop is modelled after the one in
4274                          S_parse_ident */
4275                         c = name;
4276                         while (c < e) {
4277                             if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4278                                 c += UTF8SKIP(c);
4279                                 while (c < e && isIDCONT_utf8_safe(
4280                                             (const U8*) c, (const U8*) e))
4281                                     c += UTF8SKIP(c);
4282                             }
4283                             else if (isWORDCHAR_A(*c)) {
4284                                 while (c < e && isWORDCHAR_A(*c))
4285                                     c++;
4286                             }
4287                             else if (*c == '/')
4288                                 c++;
4289                             else
4290                                 break;
4291                         }
4292
4293                         if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4294                             sv_catpvs(msg, " (you may need to install the ");
4295                             for (c = name; c < e; c++) {
4296                                 if (*c == '/') {
4297                                     sv_catpvs(msg, "::");
4298                                 }
4299                                 else {
4300                                     sv_catpvn(msg, c, 1);
4301                                 }
4302                             }
4303                             sv_catpvs(msg, " module)");
4304                         }
4305                     }
4306                     else if (memENDs(name, len, ".h")) {
4307                         sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4308                     }
4309                     else if (memENDs(name, len, ".ph")) {
4310                         sv_catpvs(msg, " (did you run h2ph?)");
4311                     }
4312
4313                     /* diag_listed_as: Can't locate %s */
4314                     DIE(aTHX_
4315                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4316                         name, msg, inc);
4317                 }
4318             }
4319             DIE(aTHX_ "Can't locate %s", name);
4320         }
4321         else {
4322 #ifdef DEFAULT_INC_EXCLUDES_DOT
4323             Stat_t st;
4324             PerlIO *io = NULL;
4325             dSAVE_ERRNO;
4326             /* the complication is to match the logic from doopen_pm() so
4327              * we don't treat do "sda1" as a previously successful "do".
4328             */
4329             bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4330                 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4331                 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4332             if (io)
4333                 PerlIO_close(io);
4334
4335             RESTORE_ERRNO;
4336             if (do_warn) {
4337                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4338                 "do \"%s\" failed, '.' is no longer in @INC; "
4339                 "did you mean do \"./%s\"?",
4340                 name, name);
4341             }
4342 #endif
4343             CLEAR_ERRSV();
4344             RETPUSHUNDEF;
4345         }
4346     }
4347     else
4348         SETERRNO(0, SS_NORMAL);
4349
4350     /* Update %INC. Assume success here to prevent recursive requirement. */
4351     /* name is never assigned to again, so len is still strlen(name)  */
4352     /* Check whether a hook in @INC has already filled %INC */
4353     if (!hook_sv) {
4354         (void)hv_store(GvHVn(PL_incgv),
4355                        unixname, unixlen, newSVpv(tryname,0),0);
4356     } else {
4357         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4358         if (!svp)
4359             (void)hv_store(GvHVn(PL_incgv),
4360                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4361     }
4362
4363     /* Now parse the file */
4364
4365     old_savestack_ix = PL_savestack_ix;
4366     SAVECOPFILE_FREE(&PL_compiling);
4367     CopFILE_set(&PL_compiling, tryname);
4368     lex_start(NULL, tryrsfp, 0);
4369
4370     if (filter_sub || filter_cache) {
4371         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4372            than hanging another SV from it. In turn, filter_add() optionally
4373            takes the SV to use as the filter (or creates a new SV if passed
4374            NULL), so simply pass in whatever value filter_cache has.  */
4375         SV * const fc = filter_cache ? newSV(0) : NULL;
4376         SV *datasv;
4377         if (fc) sv_copypv(fc, filter_cache);
4378         datasv = filter_add(S_run_user_filter, fc);
4379         IoLINES(datasv) = filter_has_file;
4380         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4381         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4382     }
4383
4384     /* switch to eval mode */
4385     assert(!CATCH_GET);
4386     cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4387     cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4388
4389     SAVECOPLINE(&PL_compiling);
4390     CopLINE_set(&PL_compiling, 0);
4391
4392     PUTBACK;
4393
4394     if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4395         op = PL_eval_start;
4396     else
4397         op = PL_op->op_next;
4398
4399     PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4400
4401     return op;
4402 }
4403
4404
4405 /* also used for: pp_dofile() */
4406
4407 PP(pp_require)
4408 {
4409     RUN_PP_CATCHABLY(Perl_pp_require);
4410
4411     {
4412         dSP;
4413         SV *sv = POPs;
4414         SvGETMAGIC(sv);
4415         PUTBACK;
4416         return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4417             ? S_require_version(aTHX_ sv)
4418             : S_require_file(aTHX_ sv);
4419     }
4420 }
4421
4422
4423 /* This is a op added to hold the hints hash for
4424    pp_entereval. The hash can be modified by the code
4425    being eval'ed, so we return a copy instead. */
4426
4427 PP(pp_hintseval)
4428 {
4429     dSP;
4430     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4431     RETURN;
4432 }
4433
4434
4435 PP(pp_entereval)
4436 {
4437     dSP;
4438     PERL_CONTEXT *cx;
4439     SV *sv;
4440     U8 gimme;
4441     U32 was;
4442     char tbuf[TYPE_DIGITS(long) + 12];
4443     bool saved_delete;
4444     char *tmpbuf;
4445     STRLEN len;
4446     CV* runcv;
4447     U32 seq, lex_flags;
4448     HV *saved_hh;
4449     bool bytes;
4450     I32 old_savestack_ix;
4451
4452     RUN_PP_CATCHABLY(Perl_pp_entereval);
4453
4454     gimme = GIMME_V;
4455     was = PL_breakable_sub_gen;
4456     saved_delete = FALSE;
4457     tmpbuf = tbuf;
4458     lex_flags = 0;
4459     saved_hh = NULL;
4460     bytes = PL_op->op_private & OPpEVAL_BYTES;
4461
4462     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4463         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4464     }
4465     else if (PL_hints & HINT_LOCALIZE_HH || (
4466                 PL_op->op_private & OPpEVAL_COPHH
4467              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4468             )) {
4469         saved_hh = cop_hints_2hv(PL_curcop, 0);
4470         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4471     }
4472     sv = POPs;
4473     if (!SvPOK(sv)) {
4474         /* make sure we've got a plain PV (no overload etc) before testing
4475          * for taint. Making a copy here is probably overkill, but better
4476          * safe than sorry */
4477         STRLEN len;
4478         const char * const p = SvPV_const(sv, len);
4479
4480         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4481         lex_flags |= LEX_START_COPIED;
4482
4483         if (bytes && SvUTF8(sv))
4484             SvPVbyte_force(sv, len);
4485     }
4486     else if (bytes && SvUTF8(sv)) {
4487         /* Don't modify someone else's scalar */
4488         STRLEN len;
4489         sv = newSVsv(sv);
4490         (void)sv_2mortal(sv);
4491         SvPVbyte_force(sv,len);
4492         lex_flags |= LEX_START_COPIED;
4493     }
4494
4495     TAINT_IF(SvTAINTED(sv));
4496     TAINT_PROPER("eval");
4497
4498     old_savestack_ix = PL_savestack_ix;
4499
4500     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4501                            ? LEX_IGNORE_UTF8_HINTS
4502                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4503                         )
4504              );
4505
4506     /* switch to eval mode */
4507
4508     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4509         SV * const temp_sv = sv_newmortal();
4510         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4511                        (unsigned long)++PL_evalseq,
4512                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4513         tmpbuf = SvPVX(temp_sv);
4514         len = SvCUR(temp_sv);
4515     }
4516     else
4517         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4518     SAVECOPFILE_FREE(&PL_compiling);
4519     CopFILE_set(&PL_compiling, tmpbuf+2);
4520     SAVECOPLINE(&PL_compiling);
4521     CopLINE_set(&PL_compiling, 1);
4522     /* special case: an eval '' executed within the DB package gets lexically
4523      * placed in the first non-DB CV rather than the current CV - this
4524      * allows the debugger to execute code, find lexicals etc, in the
4525      * scope of the code being debugged. Passing &seq gets find_runcv
4526      * to do the dirty work for us */
4527     runcv = find_runcv(&seq);
4528
4529     assert(!CATCH_GET);
4530     cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4531     cx_pusheval(cx, PL_op->op_next, NULL);
4532
4533     /* prepare to compile string */
4534
4535     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4536         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4537     else {
4538         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4539            deleting the eval's FILEGV from the stash before gv_check() runs
4540            (i.e. before run-time proper). To work around the coredump that
4541            ensues, we always turn GvMULTI_on for any globals that were
4542            introduced within evals. See force_ident(). GSAR 96-10-12 */
4543         char *const safestr = savepvn(tmpbuf, len);
4544         SAVEDELETE(PL_defstash, safestr, len);
4545         saved_delete = TRUE;
4546     }
4547
4548     PUTBACK;
4549
4550     if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4551         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4552             ?  PERLDB_LINE_OR_SAVESRC
4553             :  PERLDB_SAVESRC_NOSUBS) {
4554             /* Retain the filegv we created.  */
4555         } else if (!saved_delete) {
4556             char *const safestr = savepvn(tmpbuf, len);
4557             SAVEDELETE(PL_defstash, safestr, len);
4558         }
4559         return PL_eval_start;
4560     } else {
4561         /* We have already left the scope set up earlier thanks to the LEAVE
4562            in doeval_compile().  */
4563         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4564             ?  PERLDB_LINE_OR_SAVESRC
4565             :  PERLDB_SAVESRC_INVALID) {
4566             /* Retain the filegv we created.  */
4567         } else if (!saved_delete) {
4568             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4569         }
4570         return PL_op->op_next;
4571     }
4572 }
4573
4574
4575 /* also tail-called by pp_return */
4576
4577 PP(pp_leaveeval)
4578 {
4579     SV **oldsp;
4580     U8 gimme;
4581     PERL_CONTEXT *cx;
4582     OP *retop;
4583     int failed;
4584     CV *evalcv;
4585     bool keep;
4586
4587     PERL_ASYNC_CHECK();
4588
4589     cx = CX_CUR();
4590     assert(CxTYPE(cx) == CXt_EVAL);
4591
4592     oldsp = PL_stack_base + cx->blk_oldsp;
4593     gimme = cx->blk_gimme;
4594
4595     /* did require return a false value? */
4596     failed =    CxOLD_OP_TYPE(cx) == OP_REQUIRE
4597              && !(gimme == G_SCALAR
4598                     ? SvTRUE_NN(*PL_stack_sp)
4599                     : PL_stack_sp > oldsp);
4600
4601     if (gimme == G_VOID) {
4602         PL_stack_sp = oldsp;
4603         /* free now to avoid late-called destructors clobbering $@ */
4604         FREETMPS;
4605     }
4606     else
4607         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4608
4609     /* the cx_popeval does a leavescope, which frees the optree associated
4610      * with eval, which if it frees the nextstate associated with
4611      * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4612      * regex when running under 'use re Debug' because it needs PL_curcop
4613      * to get the current hints. So restore it early.
4614      */
4615     PL_curcop = cx->blk_oldcop;
4616
4617     /* grab this value before cx_popeval restores the old PL_in_eval */
4618     keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4619     retop = cx->blk_eval.retop;
4620     evalcv = cx->blk_eval.cv;
4621 #ifdef DEBUGGING
4622     assert(CvDEPTH(evalcv) == 1);
4623 #endif
4624     CvDEPTH(evalcv) = 0;
4625
4626     /* pop the CXt_EVAL, and if a require failed, croak */
4627     S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4628
4629     if (!keep)
4630         CLEAR_ERRSV();
4631
4632     return retop;
4633 }
4634
4635 /* Ops that implement try/catch syntax
4636  * Note the asymmetry here:
4637  *   pp_entertrycatch does two pushblocks
4638  *   pp_leavetrycatch pops only the outer one; the inner one is popped by
4639  *     pp_poptry or by stack-unwind of die within the try block
4640  */
4641
4642 PP(pp_entertrycatch)
4643 {
4644     PERL_CONTEXT *cx;
4645     const U8 gimme = GIMME_V;
4646
4647     RUN_PP_CATCHABLY(Perl_pp_entertrycatch);
4648
4649     assert(!CATCH_GET);
4650
4651     Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */
4652
4653     save_scalar(PL_errgv);
4654     CLEAR_ERRSV();
4655
4656     cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme,
4657             PL_stack_sp, PL_savestack_ix);
4658     cx_pushtry(cx, cLOGOP->op_other);
4659
4660     PL_in_eval = EVAL_INEVAL;
4661
4662     return NORMAL;
4663 }
4664
4665 PP(pp_leavetrycatch)
4666 {
4667     /* leavetrycatch is leave */
4668     return Perl_pp_leave(aTHX);
4669 }
4670
4671 PP(pp_poptry)
4672 {
4673     /* poptry is leavetry */
4674     return Perl_pp_leavetry(aTHX);
4675 }
4676
4677 PP(pp_catch)
4678 {
4679     dTARGET;
4680
4681     save_clearsv(&(PAD_SVl(PL_op->op_targ)));
4682     sv_setsv(TARG, ERRSV);
4683     CLEAR_ERRSV();
4684
4685     return cLOGOP->op_other;
4686 }
4687
4688 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4689    close to the related Perl_create_eval_scope.  */
4690 void
4691 Perl_delete_eval_scope(pTHX)
4692 {
4693     PERL_CONTEXT *cx;
4694
4695     cx = CX_CUR();
4696     CX_LEAVE_SCOPE(cx);
4697     cx_popeval(cx);
4698     cx_popblock(cx);
4699     CX_POP(cx);
4700 }
4701
4702 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4703    also needed by Perl_fold_constants.  */
4704 void
4705 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4706 {
4707     PERL_CONTEXT *cx;
4708     const U8 gimme = GIMME_V;
4709
4710     cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), gimme,
4711                     PL_stack_sp, PL_savestack_ix);
4712     cx_pusheval(cx, retop, NULL);
4713
4714     PL_in_eval = EVAL_INEVAL;
4715     if (flags & G_KEEPERR)
4716         PL_in_eval |= EVAL_KEEPERR;
4717     else
4718         CLEAR_ERRSV();
4719     if (flags & G_FAKINGEVAL) {
4720         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4721     }
4722 }
4723
4724 PP(pp_entertry)
4725 {
4726     OP *retop = cLOGOP->op_other->op_next;
4727
4728     RUN_PP_CATCHABLY(Perl_pp_entertry);
4729
4730     assert(!CATCH_GET);
4731
4732     create_eval_scope(retop, 0);
4733
4734     return PL_op->op_next;
4735 }
4736
4737
4738 /* also tail-called by pp_return */
4739
4740 PP(pp_leavetry)
4741 {
4742     SV **oldsp;
4743     U8 gimme;
4744     PERL_CONTEXT *cx;
4745     OP *retop;
4746
4747     PERL_ASYNC_CHECK();
4748
4749     cx = CX_CUR();
4750     assert(CxTYPE(cx) == CXt_EVAL);
4751     oldsp = PL_stack_base + cx->blk_oldsp;
4752     gimme = cx->blk_gimme;
4753
4754     if (gimme == G_VOID) {
4755         PL_stack_sp = oldsp;
4756         /* free now to avoid late-called destructors clobbering $@ */
4757         FREETMPS;
4758     }
4759     else
4760         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4761     CX_LEAVE_SCOPE(cx);
4762     cx_popeval(cx);
4763     cx_popblock(cx);
4764     retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop;
4765     CX_POP(cx);
4766
4767     CLEAR_ERRSV();
4768     return retop;
4769 }
4770
4771 PP(pp_entergiven)
4772 {
4773     dSP;
4774     PERL_CONTEXT *cx;
4775     const U8 gimme = GIMME_V;
4776     SV *origsv = DEFSV;
4777     SV *newsv = POPs;
4778
4779     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4780     GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4781
4782     cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4783     cx_pushgiven(cx, origsv);
4784
4785     RETURN;
4786 }
4787
4788 PP(pp_leavegiven)
4789 {
4790     PERL_CONTEXT *cx;
4791     U8 gimme;
4792     SV **oldsp;
4793     PERL_UNUSED_CONTEXT;
4794
4795     cx = CX_CUR();
4796     assert(CxTYPE(cx) == CXt_GIVEN);
4797     oldsp = PL_stack_base + cx->blk_oldsp;
4798     gimme = cx->blk_gimme;
4799
4800     if (gimme == G_VOID)
4801         PL_stack_sp = oldsp;
4802     else
4803         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4804
4805     CX_LEAVE_SCOPE(cx);
4806     cx_popgiven(cx);
4807     cx_popblock(cx);
4808     CX_POP(cx);
4809
4810     return NORMAL;
4811 }
4812
4813 /* Helper routines used by pp_smartmatch */
4814 STATIC PMOP *
4815 S_make_matcher(pTHX_ REGEXP *re)
4816 {
4817     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4818
4819     PERL_ARGS_ASSERT_MAKE_MATCHER;
4820
4821     PM_SETRE(matcher, ReREFCNT_inc(re));
4822
4823     SAVEFREEOP((OP *) matcher);
4824     ENTER_with_name("matcher"); SAVETMPS;
4825     SAVEOP();
4826     return matcher;
4827 }
4828
4829 STATIC bool
4830 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4831 {
4832     dSP;
4833     bool result;
4834
4835     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4836
4837     PL_op = (OP *) matcher;
4838     XPUSHs(sv);
4839     PUTBACK;
4840     (void) Perl_pp_match(aTHX);
4841     SPAGAIN;
4842     result = SvTRUEx(POPs);
4843     PUTBACK;
4844
4845     return result;
4846 }
4847
4848 STATIC void
4849 S_destroy_matcher(pTHX_ PMOP *matcher)
4850 {
4851     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4852     PERL_UNUSED_ARG(matcher);
4853
4854     FREETMPS;
4855     LEAVE_with_name("matcher");
4856 }
4857
4858 /* Do a smart match */
4859 PP(pp_smartmatch)
4860 {
4861     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4862     return do_smartmatch(NULL, NULL, 0);
4863 }
4864
4865 /* This version of do_smartmatch() implements the
4866  * table of smart matches that is found in perlsyn.
4867  */
4868 STATIC OP *
4869 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4870 {
4871     dSP;
4872
4873     bool object_on_left = FALSE;
4874     SV *e = TOPs;       /* e is for 'expression' */
4875     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4876
4877     /* Take care only to invoke mg_get() once for each argument.
4878      * Currently we do this by copying the SV if it's magical. */
4879     if (d) {
4880         if (!copied && SvGMAGICAL(d))
4881             d = sv_mortalcopy(d);
4882     }
4883     else
4884         d = &PL_sv_undef;
4885
4886     assert(e);
4887     if (SvGMAGICAL(e))
4888         e = sv_mortalcopy(e);
4889
4890     /* First of all, handle overload magic of the rightmost argument */
4891     if (SvAMAGIC(e)) {
4892         SV * tmpsv;
4893         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4894         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4895
4896         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4897         if (tmpsv) {
4898             SPAGAIN;
4899             (void)POPs;
4900             SETs(tmpsv);
4901             RETURN;
4902         }
4903         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4904     }
4905
4906     SP -= 2;    /* Pop the values */
4907     PUTBACK;
4908
4909     /* ~~ undef */
4910     if (!SvOK(e)) {
4911         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4912         if (SvOK(d))
4913             RETPUSHNO;
4914         else
4915             RETPUSHYES;
4916     }
4917
4918     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4919         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4920         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4921     }
4922     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4923         object_on_left = TRUE;
4924
4925     /* ~~ sub */
4926     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4927         I32 c;
4928         if (object_on_left) {
4929             goto sm_any_sub; /* Treat objects like scalars */
4930         }
4931         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4932             /* Test sub truth for each key */
4933             HE *he;
4934             bool andedresults = TRUE;
4935             HV *hv = (HV*) SvRV(d);
4936             I32 numkeys = hv_iterinit(hv);
4937             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4938             if (numkeys == 0)
4939                 RETPUSHYES;
4940             while ( (he = hv_iternext(hv)) ) {
4941                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4942                 ENTER_with_name("smartmatch_hash_key_test");
4943                 SAVETMPS;
4944                 PUSHMARK(SP);
4945                 PUSHs(hv_iterkeysv(he));
4946                 PUTBACK;
4947                 c = call_sv(e, G_SCALAR);
4948                 SPAGAIN;
4949                 if (c == 0)
4950                     andedresults = FALSE;
4951                 else
4952                     andedresults = SvTRUEx(POPs) && andedresults;
4953                 FREETMPS;
4954                 LEAVE_with_name("smartmatch_hash_key_test");
4955             }
4956             if (andedresults)
4957                 RETPUSHYES;
4958             else
4959                 RETPUSHNO;
4960         }
4961         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4962             /* Test sub truth for each element */
4963             Size_t i;
4964             bool andedresults = TRUE;
4965             AV *av = (AV*) SvRV(d);
4966             const Size_t len = av_count(av);
4967             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4968             if (len == 0)
4969                 RETPUSHYES;
4970             for (i = 0; i < len; ++i) {
4971                 SV * const * const svp = av_fetch(av, i, FALSE);
4972                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4973                 ENTER_with_name("smartmatch_array_elem_test");
4974                 SAVETMPS;
4975                 PUSHMARK(SP);
4976                 if (svp)
4977                     PUSHs(*svp);
4978                 PUTBACK;
4979                 c = call_sv(e, G_SCALAR);
4980                 SPAGAIN;
4981                 if (c == 0)
4982                     andedresults = FALSE;
4983                 else
4984                     andedresults = SvTRUEx(POPs) && andedresults;
4985                 FREETMPS;
4986                 LEAVE_with_name("smartmatch_array_elem_test");
4987             }
4988             if (andedresults)
4989                 RETPUSHYES;
4990             else
4991                 RETPUSHNO;
4992         }
4993         else {
4994           sm_any_sub:
4995             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4996             ENTER_with_name("smartmatch_coderef");
4997             SAVETMPS;
4998             PUSHMARK(SP);
4999             PUSHs(d);
5000             PUTBACK;
5001             c = call_sv(e, G_SCALAR);
5002             SPAGAIN;
5003             if (c == 0)
5004                 PUSHs(&PL_sv_no);
5005             else if (SvTEMP(TOPs))
5006                 SvREFCNT_inc_void(TOPs);
5007             FREETMPS;
5008             LEAVE_with_name("smartmatch_coderef");
5009             RETURN;
5010         }
5011     }
5012     /* ~~ %hash */
5013     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
5014         if (object_on_left) {
5015             goto sm_any_hash; /* Treat objects like scalars */
5016         }
5017         else if (!SvOK(d)) {
5018             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
5019             RETPUSHNO;
5020         }
5021         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5022             /* Check that the key-sets are identical */
5023             HE *he;
5024             HV *other_hv = MUTABLE_HV(SvRV(d));
5025             bool tied;
5026             bool other_tied;
5027             U32 this_key_count  = 0,
5028                 other_key_count = 0;
5029             HV *hv = MUTABLE_HV(SvRV(e));
5030
5031             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
5032             /* Tied hashes don't know how many keys they have. */
5033             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
5034             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
5035             if (!tied ) {
5036                 if(other_tied) {
5037                     /* swap HV sides */
5038                     HV * const temp = other_hv;
5039                     other_hv = hv;
5040                     hv = temp;
5041                     tied = TRUE;
5042                     other_tied = FALSE;
5043                 }
5044                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
5045                     RETPUSHNO;
5046             }
5047
5048             /* The hashes have the same number of keys, so it suffices
5049                to check that one is a subset of the other. */
5050             (void) hv_iterinit(hv);
5051             while ( (he = hv_iternext(hv)) ) {
5052                 SV *key = hv_iterkeysv(he);
5053
5054                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
5055                 ++ this_key_count;
5056
5057                 if(!hv_exists_ent(other_hv, key, 0)) {
5058                     (void) hv_iterinit(hv);     /* reset iterator */
5059                     RETPUSHNO;
5060                 }
5061             }
5062
5063             if (other_tied) {
5064                 (void) hv_iterinit(other_hv);
5065                 while ( hv_iternext(other_hv) )
5066                     ++other_key_count;
5067             }
5068             else
5069                 other_key_count = HvUSEDKEYS(other_hv);
5070
5071             if (this_key_count != other_key_count)
5072                 RETPUSHNO;
5073             else
5074                 RETPUSHYES;
5075         }
5076         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5077             AV * const other_av = MUTABLE_AV(SvRV(d));
5078             const Size_t other_len = av_count(other_av);
5079             Size_t i;
5080             HV *hv = MUTABLE_HV(SvRV(e));
5081
5082             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
5083             for (i = 0; i < other_len; ++i) {
5084                 SV ** const svp = av_fetch(other_av, i, FALSE);
5085                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
5086                 if (svp) {      /* ??? When can this not happen? */
5087                     if (hv_exists_ent(hv, *svp, 0))
5088                         RETPUSHYES;
5089                 }
5090             }
5091             RETPUSHNO;
5092         }
5093         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5094             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
5095           sm_regex_hash:
5096             {
5097                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5098                 HE *he;
5099                 HV *hv = MUTABLE_HV(SvRV(e));
5100
5101                 (void) hv_iterinit(hv);
5102                 while ( (he = hv_iternext(hv)) ) {
5103                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
5104                     PUTBACK;
5105                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
5106                         SPAGAIN;
5107                         (void) hv_iterinit(hv);
5108                         destroy_matcher(matcher);
5109                         RETPUSHYES;
5110                     }
5111                     SPAGAIN;
5112                 }
5113                 destroy_matcher(matcher);
5114                 RETPUSHNO;
5115             }
5116         }
5117         else {
5118           sm_any_hash:
5119             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
5120             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
5121                 RETPUSHYES;
5122             else
5123                 RETPUSHNO;
5124         }
5125     }
5126     /* ~~ @array */
5127     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
5128         if (object_on_left) {
5129             goto sm_any_array; /* Treat objects like scalars */
5130         }
5131         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5132             AV * const other_av = MUTABLE_AV(SvRV(e));
5133             const Size_t other_len = av_count(other_av);
5134             Size_t i;
5135
5136             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
5137             for (i = 0; i < other_len; ++i) {
5138                 SV ** const svp = av_fetch(other_av, i, FALSE);
5139
5140                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
5141                 if (svp) {      /* ??? When can this not happen? */
5142                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5143                         RETPUSHYES;
5144                 }
5145             }
5146             RETPUSHNO;
5147         }
5148         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5149             AV *other_av = MUTABLE_AV(SvRV(d));
5150             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
5151             if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
5152                 RETPUSHNO;
5153             else {
5154                 Size_t i;
5155                 const Size_t other_len = av_count(other_av);
5156
5157                 if (NULL == seen_this) {
5158                     seen_this = newHV();
5159                     (void) sv_2mortal(MUTABLE_SV(seen_this));
5160                 }
5161                 if (NULL == seen_other) {
5162                     seen_other = newHV();
5163                     (void) sv_2mortal(MUTABLE_SV(seen_other));
5164                 }
5165                 for(i = 0; i < other_len; ++i) {
5166                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5167                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5168
5169                     if (!this_elem || !other_elem) {
5170                         if ((this_elem && SvOK(*this_elem))
5171                                 || (other_elem && SvOK(*other_elem)))
5172                             RETPUSHNO;
5173                     }
5174                     else if (hv_exists_ent(seen_this,
5175                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5176                             hv_exists_ent(seen_other,
5177                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5178                     {
5179                         if (*this_elem != *other_elem)
5180                             RETPUSHNO;
5181                     }
5182                     else {
5183                         (void)hv_store_ent(seen_this,
5184                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5185                                 &PL_sv_undef, 0);
5186                         (void)hv_store_ent(seen_other,
5187                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5188                                 &PL_sv_undef, 0);
5189                         PUSHs(*other_elem);
5190                         PUSHs(*this_elem);
5191
5192                         PUTBACK;
5193                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
5194                         (void) do_smartmatch(seen_this, seen_other, 0);
5195                         SPAGAIN;
5196                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
5197
5198                         if (!SvTRUEx(POPs))
5199                             RETPUSHNO;
5200                     }
5201                 }
5202                 RETPUSHYES;
5203             }
5204         }
5205         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5206             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
5207           sm_regex_array:
5208             {
5209                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5210                 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5211                 Size_t i;
5212
5213                 for(i = 0; i < this_len; ++i) {
5214                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5215                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
5216                     PUTBACK;
5217                     if (svp && matcher_matches_sv(matcher, *svp)) {
5218                         SPAGAIN;
5219                         destroy_matcher(matcher);
5220                         RETPUSHYES;
5221                     }
5222                     SPAGAIN;
5223                 }
5224                 destroy_matcher(matcher);
5225                 RETPUSHNO;
5226             }
5227         }
5228         else if (!SvOK(d)) {
5229             /* undef ~~ array */
5230             const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5231             Size_t i;
5232
5233             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
5234             for (i = 0; i < this_len; ++i) {
5235                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5236                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
5237                 if (!svp || !SvOK(*svp))
5238                     RETPUSHYES;
5239             }
5240             RETPUSHNO;
5241         }
5242         else {
5243           sm_any_array:
5244             {
5245                 Size_t i;
5246                 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5247
5248                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
5249                 for (i = 0; i < this_len; ++i) {
5250                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5251                     if (!svp)
5252                         continue;
5253
5254                     PUSHs(d);
5255                     PUSHs(*svp);
5256                     PUTBACK;
5257                     /* infinite recursion isn't supposed to happen here */
5258                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
5259                     (void) do_smartmatch(NULL, NULL, 1);
5260                     SPAGAIN;
5261                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
5262                     if (SvTRUEx(POPs))
5263                         RETPUSHYES;
5264                 }
5265                 RETPUSHNO;
5266             }
5267         }
5268     }
5269     /* ~~ qr// */
5270     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5271         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5272             SV *t = d; d = e; e = t;
5273             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
5274             goto sm_regex_hash;
5275         }
5276         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5277             SV *t = d; d = e; e = t;
5278             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
5279             goto sm_regex_array;
5280         }
5281         else {
5282             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5283             bool result;
5284
5285             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
5286             PUTBACK;
5287             result = matcher_matches_sv(matcher, d);
5288             SPAGAIN;
5289             PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5290             destroy_matcher(matcher);
5291             RETURN;
5292         }
5293     }
5294     /* ~~ scalar */
5295     /* See if there is overload magic on left */
5296     else if (object_on_left && SvAMAGIC(d)) {
5297         SV *tmpsv;
5298         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
5299         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
5300         PUSHs(d); PUSHs(e);
5301         PUTBACK;
5302         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5303         if (tmpsv) {
5304             SPAGAIN;
5305             (void)POPs;
5306             SETs(tmpsv);
5307             RETURN;
5308         }
5309         SP -= 2;
5310         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
5311         goto sm_any_scalar;
5312     }
5313     else if (!SvOK(d)) {
5314         /* undef ~~ scalar ; we already know that the scalar is SvOK */
5315         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
5316         RETPUSHNO;
5317     }
5318     else
5319   sm_any_scalar:
5320     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5321         DEBUG_M(if (SvNIOK(e))
5322                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
5323                 else
5324                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
5325         );
5326         /* numeric comparison */
5327         PUSHs(d); PUSHs(e);
5328         PUTBACK;
5329         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5330             (void) Perl_pp_i_eq(aTHX);
5331         else
5332             (void) Perl_pp_eq(aTHX);
5333         SPAGAIN;
5334         if (SvTRUEx(POPs))
5335             RETPUSHYES;
5336         else
5337             RETPUSHNO;
5338     }
5339
5340     /* As a last resort, use string comparison */
5341     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
5342     PUSHs(d); PUSHs(e);
5343     PUTBACK;
5344     return Perl_pp_seq(aTHX);
5345 }
5346
5347 PP(pp_enterwhen)
5348 {
5349     dSP;
5350     PERL_CONTEXT *cx;
5351     const U8 gimme = GIMME_V;
5352
5353     /* This is essentially an optimization: if the match
5354        fails, we don't want to push a context and then
5355        pop it again right away, so we skip straight
5356        to the op that follows the leavewhen.
5357        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5358     */
5359     if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5360         if (gimme == G_SCALAR)
5361             PUSHs(&PL_sv_undef);
5362         RETURNOP(cLOGOP->op_other->op_next);
5363     }
5364
5365     cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5366     cx_pushwhen(cx);
5367
5368     RETURN;
5369 }
5370
5371 PP(pp_leavewhen)
5372 {
5373     I32 cxix;
5374     PERL_CONTEXT *cx;
5375     U8 gimme;
5376     SV **oldsp;
5377
5378     cx = CX_CUR();
5379     assert(CxTYPE(cx) == CXt_WHEN);
5380     gimme = cx->blk_gimme;
5381
5382     cxix = dopoptogivenfor(cxstack_ix);
5383     if (cxix < 0)
5384         /* diag_listed_as: Can't "when" outside a topicalizer */
5385         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5386                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5387
5388     oldsp = PL_stack_base + cx->blk_oldsp;
5389     if (gimme == G_VOID)
5390         PL_stack_sp = oldsp;
5391     else
5392         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5393
5394     /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5395     assert(cxix < cxstack_ix);
5396     dounwind(cxix);
5397
5398     cx = &cxstack[cxix];
5399
5400     if (CxFOREACH(cx)) {
5401         /* emulate pp_next. Note that any stack(s) cleanup will be
5402          * done by the pp_unstack which op_nextop should point to */
5403         cx = CX_CUR();
5404         cx_topblock(cx);
5405         PL_curcop = cx->blk_oldcop;
5406         return cx->blk_loop.my_op->op_nextop;
5407     }
5408     else {
5409         PERL_ASYNC_CHECK();
5410         assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5411         return cx->blk_givwhen.leave_op;
5412     }
5413 }
5414
5415 PP(pp_continue)
5416 {
5417     I32 cxix;
5418     PERL_CONTEXT *cx;
5419     OP *nextop;
5420
5421     cxix = dopoptowhen(cxstack_ix);
5422     if (cxix < 0)
5423         DIE(aTHX_ "Can't \"continue\" outside a when block");
5424
5425     if (cxix < cxstack_ix)
5426         dounwind(cxix);
5427
5428     cx = CX_CUR();
5429     assert(CxTYPE(cx) == CXt_WHEN);
5430     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5431     CX_LEAVE_SCOPE(cx);
5432     cx_popwhen(cx);
5433     cx_popblock(cx);
5434     nextop = cx->blk_givwhen.leave_op->op_next;
5435     CX_POP(cx);
5436
5437     return nextop;
5438 }
5439
5440 PP(pp_break)
5441 {
5442     I32 cxix;
5443     PERL_CONTEXT *cx;
5444
5445     cxix = dopoptogivenfor(cxstack_ix);
5446     if (cxix < 0)
5447         DIE(aTHX_ "Can't \"break\" outside a given block");
5448
5449     cx = &cxstack[cxix];
5450     if (CxFOREACH(cx))
5451         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5452
5453     if (cxix < cxstack_ix)
5454         dounwind(cxix);
5455
5456     /* Restore the sp at the time we entered the given block */
5457     cx = CX_CUR();
5458     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5459
5460     return cx->blk_givwhen.leave_op;
5461 }
5462
5463 static void
5464 invoke_defer_block(pTHX_ void *_arg)
5465 {
5466     OP *start = (OP *)_arg;
5467 #ifdef DEBUGGING
5468     I32 was_cxstack_ix = cxstack_ix;
5469 #endif
5470
5471     cx_pushblock(CXt_DEFER, G_VOID, PL_stack_sp, PL_savestack_ix);
5472     ENTER;
5473     SAVETMPS;
5474
5475     SAVEOP();
5476     PL_op = start;
5477
5478     CALLRUNOPS(aTHX);
5479
5480     FREETMPS;
5481     LEAVE;
5482
5483     {
5484         PERL_CONTEXT *cx;
5485
5486         cx = CX_CUR();
5487         assert(CxTYPE(cx) == CXt_DEFER);
5488
5489         PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5490
5491         CX_LEAVE_SCOPE(cx);
5492         cx_popblock(cx);
5493         CX_POP(cx);
5494     }
5495
5496     assert(cxstack_ix == was_cxstack_ix);
5497 }
5498
5499 PP(pp_pushdefer)
5500 {
5501     SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
5502
5503     return NORMAL;
5504 }
5505
5506 static MAGIC *
5507 S_doparseform(pTHX_ SV *sv)
5508 {
5509     STRLEN len;
5510     char *s = SvPV(sv, len);
5511     char *send;
5512     char *base = NULL; /* start of current field */
5513     I32 skipspaces = 0; /* number of contiguous spaces seen */
5514     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5515     bool repeat    = FALSE; /* ~~ seen on this line */
5516     bool postspace = FALSE; /* a text field may need right padding */
5517     U32 *fops;
5518     U32 *fpc;
5519     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5520     I32 arg;
5521     bool ischop;            /* it's a ^ rather than a @ */
5522     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5523     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5524     MAGIC *mg = NULL;
5525     SV *sv_copy;
5526
5527     PERL_ARGS_ASSERT_DOPARSEFORM;
5528
5529     if (len == 0)
5530         Perl_croak(aTHX_ "Null picture in formline");
5531
5532     if (SvTYPE(sv) >= SVt_PVMG) {
5533         /* This might, of course, still return NULL.  */
5534         mg = mg_find(sv, PERL_MAGIC_fm);
5535     } else {
5536         sv_upgrade(sv, SVt_PVMG);
5537     }
5538
5539     if (mg) {
5540         /* still the same as previously-compiled string? */
5541         SV *old = mg->mg_obj;
5542         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5543               && len == SvCUR(old)
5544               && strnEQ(SvPVX(old), s, len)
5545         ) {
5546             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5547             return mg;
5548         }
5549
5550         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5551         Safefree(mg->mg_ptr);
5552         mg->mg_ptr = NULL;
5553         SvREFCNT_dec(old);
5554         mg->mg_obj = NULL;
5555     }
5556     else {
5557         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5558         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5559     }
5560
5561     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5562     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5563     send = s + len;
5564
5565
5566     /* estimate the buffer size needed */
5567     for (base = s; s <= send; s++) {
5568         if (*s == '\n' || *s == '@' || *s == '^')
5569             maxops += 10;
5570     }
5571     s = base;
5572     base = NULL;
5573
5574     Newx(fops, maxops, U32);
5575     fpc = fops;
5576
5577     if (s < send) {
5578         linepc = fpc;
5579         *fpc++ = FF_LINEMARK;
5580         noblank = repeat = FALSE;
5581         base = s;
5582     }
5583
5584     while (s <= send) {
5585         switch (*s++) {
5586         default:
5587             skipspaces = 0;
5588             continue;
5589
5590         case '~':
5591             if (*s == '~') {
5592                 repeat = TRUE;
5593                 skipspaces++;
5594                 s++;
5595             }
5596             noblank = TRUE;
5597             /* FALLTHROUGH */
5598         case ' ': case '\t':
5599             skipspaces++;
5600             continue;
5601         case 0:
5602             if (s < send) {
5603                 skipspaces = 0;
5604                 continue;
5605             }
5606             /* FALLTHROUGH */
5607         case '\n':
5608             arg = s - base;
5609             skipspaces++;
5610             arg -= skipspaces;
5611             if (arg) {
5612                 if (postspace)
5613                     *fpc++ = FF_SPACE;
5614                 *fpc++ = FF_LITERAL;
5615                 *fpc++ = (U32)arg;
5616             }
5617             postspace = FALSE;
5618             if (s <= send)
5619                 skipspaces--;
5620             if (skipspaces) {
5621                 *fpc++ = FF_SKIP;
5622                 *fpc++ = (U32)skipspaces;
5623             }
5624             skipspaces = 0;
5625             if (s <= send)
5626                 *fpc++ = FF_NEWLINE;
5627             if (noblank) {
5628                 *fpc++ = FF_BLANK;
5629                 if (repeat)
5630                     arg = fpc - linepc + 1;
5631                 else
5632                     arg = 0;
5633                 *fpc++ = (U32)arg;
5634             }
5635             if (s < send) {
5636                 linepc = fpc;
5637                 *fpc++ = FF_LINEMARK;
5638                 noblank = repeat = FALSE;
5639                 base = s;
5640             }
5641             else
5642                 s++;
5643             continue;
5644
5645         case '@':
5646         case '^':
5647             ischop = s[-1] == '^';
5648
5649             if (postspace) {
5650                 *fpc++ = FF_SPACE;
5651                 postspace = FALSE;
5652             }
5653             arg = (s - base) - 1;
5654             if (arg) {
5655                 *fpc++ = FF_LITERAL;
5656                 *fpc++ = (U32)arg;
5657             }
5658
5659             base = s - 1;
5660             *fpc++ = FF_FETCH;
5661             if (*s == '*') { /*  @* or ^*  */
5662                 s++;
5663                 *fpc++ = 2;  /* skip the @* or ^* */
5664                 if (ischop) {
5665                     *fpc++ = FF_LINESNGL;
5666                     *fpc++ = FF_CHOP;
5667                 } else
5668                     *fpc++ = FF_LINEGLOB;
5669             }
5670             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5671                 arg = ischop ? FORM_NUM_BLANK : 0;
5672                 base = s - 1;
5673                 while (*s == '#')
5674                     s++;
5675                 if (*s == '.') {
5676                     const char * const f = ++s;
5677                     while (*s == '#')
5678                         s++;
5679                     arg |= FORM_NUM_POINT + (s - f);
5680                 }
5681                 *fpc++ = s - base;              /* fieldsize for FETCH */
5682                 *fpc++ = FF_DECIMAL;
5683                 *fpc++ = (U32)arg;
5684                 unchopnum |= ! ischop;
5685             }
5686             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5687                 arg = ischop ? FORM_NUM_BLANK : 0;
5688                 base = s - 1;
5689                 s++;                                /* skip the '0' first */
5690                 while (*s == '#')
5691                     s++;
5692                 if (*s == '.') {
5693                     const char * const f = ++s;
5694                     while (*s == '#')
5695                         s++;
5696                     arg |= FORM_NUM_POINT + (s - f);
5697                 }
5698                 *fpc++ = s - base;                /* fieldsize for FETCH */
5699                 *fpc++ = FF_0DECIMAL;
5700                 *fpc++ = (U32)arg;
5701                 unchopnum |= ! ischop;
5702             }
5703             else {                              /* text field */
5704                 I32 prespace = 0;
5705                 bool ismore = FALSE;
5706
5707                 if (*s == '>') {
5708                     while (*++s == '>') ;
5709                     prespace = FF_SPACE;
5710                 }
5711                 else if (*s == '|') {
5712                     while (*++s == '|') ;
5713                     prespace = FF_HALFSPACE;
5714                     postspace = TRUE;
5715                 }
5716                 else {
5717                     if (*s == '<')
5718                         while (*++s == '<') ;
5719                     postspace = TRUE;
5720                 }
5721                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5722                     s += 3;
5723                     ismore = TRUE;
5724                 }
5725                 *fpc++ = s - base;              /* fieldsize for FETCH */
5726
5727                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5728
5729                 if (prespace)
5730                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5731                 *fpc++ = FF_ITEM;
5732                 if (ismore)
5733                     *fpc++ = FF_MORE;
5734                 if (ischop)
5735                     *fpc++ = FF_CHOP;
5736             }
5737             base = s;
5738             skipspaces = 0;
5739             continue;
5740         }
5741     }
5742     *fpc++ = FF_END;
5743
5744     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5745     arg = fpc - fops;
5746
5747     mg->mg_ptr = (char *) fops;
5748     mg->mg_len = arg * sizeof(U32);
5749     mg->mg_obj = sv_copy;
5750     mg->mg_flags |= MGf_REFCOUNTED;
5751
5752     if (unchopnum && repeat)
5753         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5754
5755     return mg;
5756 }
5757
5758
5759 STATIC bool
5760 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5761 {
5762     /* Can value be printed in fldsize chars, using %*.*f ? */
5763     NV pwr = 1;
5764     NV eps = 0.5;
5765     bool res = FALSE;
5766     int intsize = fldsize - (value < 0 ? 1 : 0);
5767
5768     if (frcsize & FORM_NUM_POINT)
5769         intsize--;
5770     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5771     intsize -= frcsize;
5772
5773     while (intsize--) pwr *= 10.0;
5774     while (frcsize--) eps /= 10.0;
5775
5776     if( value >= 0 ){
5777         if (value + eps >= pwr)
5778             res = TRUE;
5779     } else {
5780         if (value - eps <= -pwr)
5781             res = TRUE;
5782     }
5783     return res;
5784 }
5785
5786 static I32
5787 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5788 {
5789     SV * const datasv = FILTER_DATA(idx);
5790     const int filter_has_file = IoLINES(datasv);
5791     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5792     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5793     int status = 0;
5794     SV *upstream;
5795     STRLEN got_len;
5796     char *got_p = NULL;
5797     char *prune_from = NULL;
5798     bool read_from_cache = FALSE;
5799     STRLEN umaxlen;
5800     SV *err = NULL;
5801
5802     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5803
5804     assert(maxlen >= 0);
5805     umaxlen = maxlen;
5806
5807     /* I was having segfault trouble under Linux 2.2.5 after a
5808        parse error occurred.  (Had to hack around it with a test
5809        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5810        not sure where the trouble is yet.  XXX */
5811
5812     {
5813         SV *const cache = datasv;
5814         if (SvOK(cache)) {
5815             STRLEN cache_len;
5816             const char *cache_p = SvPV(cache, cache_len);
5817             STRLEN take = 0;
5818
5819             if (umaxlen) {
5820                 /* Running in block mode and we have some cached data already.
5821                  */
5822                 if (cache_len >= umaxlen) {
5823                     /* In fact, so much data we don't even need to call
5824                        filter_read.  */
5825                     take = umaxlen;
5826                 }
5827             } else {
5828                 const char *const first_nl =
5829                     (const char *)memchr(cache_p, '\n', cache_len);
5830                 if (first_nl) {
5831                     take = first_nl + 1 - cache_p;
5832                 }
5833             }
5834             if (take) {
5835                 sv_catpvn(buf_sv, cache_p, take);
5836                 sv_chop(cache, cache_p + take);
5837                 /* Definitely not EOF  */
5838                 return 1;
5839             }
5840
5841             sv_catsv(buf_sv, cache);
5842             if (umaxlen) {
5843                 umaxlen -= cache_len;
5844             }
5845             SvOK_off(cache);
5846             read_from_cache = TRUE;
5847         }
5848     }
5849
5850     /* Filter API says that the filter appends to the contents of the buffer.
5851        Usually the buffer is "", so the details don't matter. But if it's not,
5852        then clearly what it contains is already filtered by this filter, so we
5853        don't want to pass it in a second time.
5854        I'm going to use a mortal in case the upstream filter croaks.  */
5855     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5856         ? sv_newmortal() : buf_sv;
5857     SvUPGRADE(upstream, SVt_PV);
5858
5859     if (filter_has_file) {
5860         status = FILTER_READ(idx+1, upstream, 0);
5861     }
5862
5863     if (filter_sub && status >= 0) {
5864         dSP;
5865         int count;
5866
5867         ENTER_with_name("call_filter_sub");
5868         SAVE_DEFSV;
5869         SAVETMPS;
5870         EXTEND(SP, 2);
5871
5872         DEFSV_set(upstream);
5873         PUSHMARK(SP);
5874         PUSHs(&PL_sv_zero);
5875         if (filter_state) {
5876             PUSHs(filter_state);
5877         }
5878         PUTBACK;
5879         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5880         SPAGAIN;
5881
5882         if (count > 0) {
5883             SV *out = POPs;
5884             SvGETMAGIC(out);
5885             if (SvOK(out)) {
5886                 status = SvIV(out);
5887             }
5888             else {
5889                 SV * const errsv = ERRSV;
5890                 if (SvTRUE_NN(errsv))
5891                     err = newSVsv(errsv);
5892             }
5893         }
5894
5895         PUTBACK;
5896         FREETMPS;
5897         LEAVE_with_name("call_filter_sub");
5898     }
5899
5900     if (SvGMAGICAL(upstream)) {
5901         mg_get(upstream);
5902         if (upstream == buf_sv) mg_free(buf_sv);
5903     }
5904     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5905     if(!err && SvOK(upstream)) {
5906         got_p = SvPV_nomg(upstream, got_len);
5907         if (umaxlen) {
5908             if (got_len > umaxlen) {
5909                 prune_from = got_p + umaxlen;
5910             }
5911         } else {
5912             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5913             if (first_nl && first_nl + 1 < got_p + got_len) {
5914                 /* There's a second line here... */
5915                 prune_from = first_nl + 1;
5916             }
5917         }
5918     }
5919     if (!err && prune_from) {
5920         /* Oh. Too long. Stuff some in our cache.  */
5921         STRLEN cached_len = got_p + got_len - prune_from;
5922         SV *const cache = datasv;
5923
5924         if (SvOK(cache)) {
5925             /* Cache should be empty.  */
5926             assert(!SvCUR(cache));
5927         }
5928
5929         sv_setpvn(cache, prune_from, cached_len);
5930         /* If you ask for block mode, you may well split UTF-8 characters.
5931            "If it breaks, you get to keep both parts"
5932            (Your code is broken if you  don't put them back together again
5933            before something notices.) */
5934         if (SvUTF8(upstream)) {
5935             SvUTF8_on(cache);
5936         }
5937         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5938         else
5939             /* Cannot just use sv_setpvn, as that could free the buffer
5940                before we have a chance to assign it. */
5941             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5942                       got_len - cached_len);
5943         *prune_from = 0;
5944         /* Can't yet be EOF  */
5945         if (status == 0)
5946             status = 1;
5947     }
5948
5949     /* If they are at EOF but buf_sv has something in it, then they may never
5950        have touched the SV upstream, so it may be undefined.  If we naively
5951        concatenate it then we get a warning about use of uninitialised value.
5952     */
5953     if (!err && upstream != buf_sv &&
5954         SvOK(upstream)) {
5955         sv_catsv_nomg(buf_sv, upstream);
5956     }
5957     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5958
5959     if (status <= 0) {
5960         IoLINES(datasv) = 0;
5961         if (filter_state) {
5962             SvREFCNT_dec(filter_state);
5963             IoTOP_GV(datasv) = NULL;
5964         }
5965         if (filter_sub) {
5966             SvREFCNT_dec(filter_sub);
5967             IoBOTTOM_GV(datasv) = NULL;
5968         }
5969         filter_del(S_run_user_filter);
5970     }
5971
5972     if (err)
5973         croak_sv(err);
5974
5975     if (status == 0 && read_from_cache) {
5976         /* If we read some data from the cache (and by getting here it implies
5977            that we emptied the cache) then we aren't yet at EOF, and mustn't
5978            report that to our caller.  */
5979         return 1;
5980     }
5981     return status;
5982 }
5983
5984 /*
5985  * ex: set ts=8 sts=4 sw=4 et:
5986  */