pp_ctl.c

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