pp_ctl.c

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