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