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