pp_ctl.c

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