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
3510 STATIC PerlIO *
3511 S_check_type_and_open(pTHX_ SV *name)
3512 {
3513     Stat_t st;
3514     STRLEN len;
3515     PerlIO * retio;
3516     const char *p = SvPV_const(name, len);
3517     int st_rc;
3518
3519     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3520
3521     /* checking here captures a reasonable error message when
3522      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3523      * user gets a confusing message about looking for the .pmc file
3524      * rather than for the .pm file so do the check in S_doopen_pm when
3525      * PMC is on instead of here. S_doopen_pm calls this func.
3526      * This check prevents a \0 in @INC causing problems.
3527      */
3528 #ifdef PERL_DISABLE_PMC
3529     if (!IS_SAFE_PATHNAME(p, len, "require"))
3530         return NULL;
3531 #endif
3532
3533     /* on Win32 stat is expensive (it does an open() and close() twice and
3534        a couple other IO calls), the open will fail with a dir on its own with
3535        errno EACCES, so only do a stat to separate a dir from a real EACCES
3536        caused by user perms */
3537 #ifndef WIN32
3538     /* we use the value of errno later to see how stat() or open() failed.
3539      * We don't want it set if the stat succeeded but we still failed,
3540      * such as if the name exists, but is a directory */
3541     errno = 0;
3542
3543     st_rc = PerlLIO_stat(p, &st);
3544
3545     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3546         return NULL;
3547     }
3548 #endif
3549
3550     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3551 #ifdef WIN32
3552     /* EACCES stops the INC search early in pp_require to implement
3553        feature RT #113422 */
3554     if(!retio && errno == EACCES) { /* exists but probably a directory */
3555         int eno;
3556         st_rc = PerlLIO_stat(p, &st);
3557         if (st_rc >= 0) {
3558             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3559                 eno = 0;
3560             else
3561                 eno = EACCES;
3562             errno = eno;
3563         }
3564     }
3565 #endif
3566     return retio;
3567 }
3568
3569 #ifndef PERL_DISABLE_PMC
3570 STATIC PerlIO *
3571 S_doopen_pm(pTHX_ SV *name)
3572 {
3573     STRLEN namelen;
3574     const char *p = SvPV_const(name, namelen);
3575
3576     PERL_ARGS_ASSERT_DOOPEN_PM;
3577
3578     /* check the name before trying for the .pmc name to avoid the
3579      * warning referring to the .pmc which the user probably doesn't
3580      * know or care about
3581      */
3582     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3583         return NULL;
3584
3585     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3586         SV *const pmcsv = sv_newmortal();
3587         PerlIO * pmcio;
3588
3589         SvSetSV_nosteal(pmcsv,name);
3590         sv_catpvs(pmcsv, "c");
3591
3592         pmcio = check_type_and_open(pmcsv);
3593         if (pmcio)
3594             return pmcio;
3595     }
3596     return check_type_and_open(name);
3597 }
3598 #else
3599 #  define doopen_pm(name) check_type_and_open(name)
3600 #endif /* !PERL_DISABLE_PMC */
3601
3602 /* require doesn't search for absolute names, or when the name is
3603    explicitly relative the current directory */
3604 PERL_STATIC_INLINE bool
3605 S_path_is_searchable(const char *name)
3606 {
3607     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3608
3609     if (PERL_FILE_IS_ABSOLUTE(name)
3610 #ifdef WIN32
3611         || (*name == '.' && ((name[1] == '/' ||
3612                              (name[1] == '.' && name[2] == '/'))
3613                          || (name[1] == '\\' ||
3614                              ( name[1] == '.' && name[2] == '\\')))
3615             )
3616 #else
3617         || (*name == '.' && (name[1] == '/' ||
3618                              (name[1] == '.' && name[2] == '/')))
3619 #endif
3620          )
3621     {
3622         return FALSE;
3623     }
3624     else
3625         return TRUE;
3626 }
3627
3628
3629 /* implement 'require 5.010001' */
3630
3631 static OP *
3632 S_require_version(pTHX_ SV *sv)
3633 {
3634     dVAR; dSP;
3635
3636     sv = sv_2mortal(new_version(sv));
3637     if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3638         upg_version(PL_patchlevel, TRUE);
3639     if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3640         if ( vcmp(sv,PL_patchlevel) <= 0 )
3641             DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3642                 SVfARG(sv_2mortal(vnormal(sv))),
3643                 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3644             );
3645     }
3646     else {
3647         if ( vcmp(sv,PL_patchlevel) > 0 ) {
3648             I32 first = 0;
3649             AV *lav;
3650             SV * const req = SvRV(sv);
3651             SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3652
3653             /* get the left hand term */
3654             lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3655
3656             first  = SvIV(*av_fetch(lav,0,0));
3657             if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3658                 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3659                 || av_tindex(lav) > 1            /* FP with > 3 digits */
3660                 || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3661                ) {
3662                 DIE(aTHX_ "Perl %" SVf " required--this is only "
3663                     "%" SVf ", stopped",
3664                     SVfARG(sv_2mortal(vnormal(req))),
3665                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3666                 );
3667             }
3668             else { /* probably 'use 5.10' or 'use 5.8' */
3669                 SV *hintsv;
3670                 I32 second = 0;
3671
3672                 if (av_tindex(lav)>=1)
3673                     second = SvIV(*av_fetch(lav,1,0));
3674
3675                 second /= second >= 600  ? 100 : 10;
3676                 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3677                                        (int)first, (int)second);
3678                 upg_version(hintsv, TRUE);
3679
3680                 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3681                     "--this is only %" SVf ", stopped",
3682                     SVfARG(sv_2mortal(vnormal(req))),
3683                     SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3684                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3685                 );
3686             }
3687         }
3688     }
3689
3690     RETPUSHYES;
3691 }
3692
3693 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3694  * The first form will have already been converted at compile time to
3695  * the second form */
3696
3697 static OP *
3698 S_require_file(pTHX_ SV *const sv)
3699 {
3700     dVAR; dSP;
3701
3702     PERL_CONTEXT *cx;
3703     const char *name;
3704     STRLEN len;
3705     char * unixname;
3706     STRLEN unixlen;
3707 #ifdef VMS
3708     int vms_unixname = 0;
3709     char *unixdir;
3710 #endif
3711     const char *tryname = NULL;
3712     SV *namesv = NULL;
3713     const U8 gimme = GIMME_V;
3714     int filter_has_file = 0;
3715     PerlIO *tryrsfp = NULL;
3716     SV *filter_cache = NULL;
3717     SV *filter_state = NULL;
3718     SV *filter_sub = NULL;
3719     SV *hook_sv = NULL;
3720     OP *op;
3721     int saved_errno;
3722     bool path_searchable;
3723     I32 old_savestack_ix;
3724     const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3725     const char *const op_name = op_is_require ? "require" : "do";
3726
3727     assert(op_is_require || PL_op->op_type == OP_DOFILE);
3728
3729     if (!SvOK(sv))
3730         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3731     name = SvPV_nomg_const(sv, len);
3732     if (!(name && len > 0 && *name))
3733         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3734
3735     if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3736         if (!op_is_require) {
3737             CLEAR_ERRSV();
3738             RETPUSHUNDEF;
3739         }
3740         DIE(aTHX_ "Can't locate %s:   %s",
3741             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3742                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3743             Strerror(ENOENT));
3744     }
3745     TAINT_PROPER(op_name);
3746
3747     path_searchable = path_is_searchable(name);
3748
3749 #ifdef VMS
3750     /* The key in the %ENV hash is in the syntax of file passed as the argument
3751      * usually this is in UNIX format, but sometimes in VMS format, which
3752      * can result in a module being pulled in more than once.
3753      * To prevent this, the key must be stored in UNIX format if the VMS
3754      * name can be translated to UNIX.
3755      */
3756
3757     if ((unixname =
3758           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3759          != NULL) {
3760         unixlen = strlen(unixname);
3761         vms_unixname = 1;
3762     }
3763     else
3764 #endif
3765     {
3766         /* if not VMS or VMS name can not be translated to UNIX, pass it
3767          * through.
3768          */
3769         unixname = (char *) name;
3770         unixlen = len;
3771     }
3772     if (op_is_require) {
3773         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3774                                           unixname, unixlen, 0);
3775         if ( svp ) {
3776             if (*svp != &PL_sv_undef)
3777                 RETPUSHYES;
3778             else
3779                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3780                             "Compilation failed in require", unixname);
3781         }
3782
3783         if (PL_op->op_flags & OPf_KIDS) {
3784             SVOP * const kid = (SVOP*)cUNOP->op_first;
3785
3786             if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3787                 /* require foo (or use foo) with a bareword.
3788                    Perl_load_module fakes up the identical optree, but its
3789                    arguments aren't restricted by the parser to real barewords.
3790                 */
3791                 const STRLEN package_len = len - 3;
3792                 const char slashdot[2] = {'/', '.'};
3793 #ifdef DOSISH
3794                 const char backslashdot[2] = {'\\', '.'};
3795 #endif
3796
3797                 /* Disallow *purported* barewords that map to absolute
3798                    filenames, filenames relative to the current or parent
3799                    directory, or (*nix) hidden filenames.  Also sanity check
3800                    that the generated filename ends .pm  */
3801                 if (!path_searchable || len < 3 || name[0] == '.'
3802                     || !memEQ(name + package_len, ".pm", 3))
3803                     DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3804                 if (memchr(name, 0, package_len)) {
3805                     /* diag_listed_as: Bareword in require contains "%s" */
3806                     DIE(aTHX_ "Bareword in require contains \"\\0\"");
3807                 }
3808                 if (ninstr(name, name + package_len, slashdot,
3809                            slashdot + sizeof(slashdot))) {
3810                     /* diag_listed_as: Bareword in require contains "%s" */
3811                     DIE(aTHX_ "Bareword in require contains \"/.\"");
3812                 }
3813 #ifdef DOSISH
3814                 if (ninstr(name, name + package_len, backslashdot,
3815                            backslashdot + sizeof(backslashdot))) {
3816                     /* diag_listed_as: Bareword in require contains "%s" */
3817                     DIE(aTHX_ "Bareword in require contains \"\\.\"");
3818                 }
3819 #endif
3820             }
3821         }
3822     }
3823
3824     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3825
3826     /* prepare to compile file */
3827
3828     if (!path_searchable) {
3829         /* At this point, name is SvPVX(sv)  */
3830         tryname = name;
3831         tryrsfp = doopen_pm(sv);
3832     }
3833     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3834         AV * const ar = GvAVn(PL_incgv);
3835         SSize_t i;
3836 #ifdef VMS
3837         if (vms_unixname)
3838 #endif
3839         {
3840             SV *nsv = sv;
3841             namesv = newSV_type(SVt_PV);
3842             for (i = 0; i <= AvFILL(ar); i++) {
3843                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3844
3845                 SvGETMAGIC(dirsv);
3846                 if (SvROK(dirsv)) {
3847                     int count;
3848                     SV **svp;
3849                     SV *loader = dirsv;
3850
3851                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3852                         && !SvOBJECT(SvRV(loader)))
3853                     {
3854                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3855                         SvGETMAGIC(loader);
3856                     }
3857
3858                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3859                                    PTR2UV(SvRV(dirsv)), name);
3860                     tryname = SvPVX_const(namesv);
3861                     tryrsfp = NULL;
3862
3863                     if (SvPADTMP(nsv)) {
3864                         nsv = sv_newmortal();
3865                         SvSetSV_nosteal(nsv,sv);
3866                     }
3867
3868                     ENTER_with_name("call_INC");
3869                     SAVETMPS;
3870                     EXTEND(SP, 2);
3871
3872                     PUSHMARK(SP);
3873                     PUSHs(dirsv);
3874                     PUSHs(nsv);
3875                     PUTBACK;
3876                     if (SvGMAGICAL(loader)) {
3877                         SV *l = sv_newmortal();
3878                         sv_setsv_nomg(l, loader);
3879                         loader = l;
3880                     }
3881                     if (sv_isobject(loader))
3882                         count = call_method("INC", G_ARRAY);
3883                     else
3884                         count = call_sv(loader, G_ARRAY);
3885                     SPAGAIN;
3886
3887                     if (count > 0) {
3888                         int i = 0;
3889                         SV *arg;
3890
3891                         SP -= count - 1;
3892                         arg = SP[i++];
3893
3894                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3895                             && !isGV_with_GP(SvRV(arg))) {
3896                             filter_cache = SvRV(arg);
3897
3898                             if (i < count) {
3899                                 arg = SP[i++];
3900                             }
3901                         }
3902
3903                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3904                             arg = SvRV(arg);
3905                         }
3906
3907                         if (isGV_with_GP(arg)) {
3908                             IO * const io = GvIO((const GV *)arg);
3909
3910                             ++filter_has_file;
3911
3912                             if (io) {
3913                                 tryrsfp = IoIFP(io);
3914                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3915                                     PerlIO_close(IoOFP(io));
3916                                 }
3917                                 IoIFP(io) = NULL;
3918                                 IoOFP(io) = NULL;
3919                             }
3920
3921                             if (i < count) {
3922                                 arg = SP[i++];
3923                             }
3924                         }
3925
3926                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3927                             filter_sub = arg;
3928                             SvREFCNT_inc_simple_void_NN(filter_sub);
3929
3930                             if (i < count) {
3931                                 filter_state = SP[i];
3932                                 SvREFCNT_inc_simple_void(filter_state);
3933                             }
3934                         }
3935
3936                         if (!tryrsfp && (filter_cache || filter_sub)) {
3937                             tryrsfp = PerlIO_open(BIT_BUCKET,
3938                                                   PERL_SCRIPT_MODE);
3939                         }
3940                         SP--;
3941                     }
3942
3943                     /* FREETMPS may free our filter_cache */
3944                     SvREFCNT_inc_simple_void(filter_cache);
3945
3946                     PUTBACK;
3947                     FREETMPS;
3948                     LEAVE_with_name("call_INC");
3949
3950                     /* Now re-mortalize it. */
3951                     sv_2mortal(filter_cache);
3952
3953                     /* Adjust file name if the hook has set an %INC entry.
3954                        This needs to happen after the FREETMPS above.  */
3955                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3956                     if (svp)
3957                         tryname = SvPV_nolen_const(*svp);
3958
3959                     if (tryrsfp) {
3960                         hook_sv = dirsv;
3961                         break;
3962                     }
3963
3964                     filter_has_file = 0;
3965                     filter_cache = NULL;
3966                     if (filter_state) {
3967                         SvREFCNT_dec_NN(filter_state);
3968                         filter_state = NULL;
3969                     }
3970                     if (filter_sub) {
3971                         SvREFCNT_dec_NN(filter_sub);
3972                         filter_sub = NULL;
3973                     }
3974                 }
3975                 else {
3976                   if (path_searchable) {
3977                     const char *dir;
3978                     STRLEN dirlen;
3979
3980                     if (SvOK(dirsv)) {
3981                         dir = SvPV_nomg_const(dirsv, dirlen);
3982                     } else {
3983                         dir = "";
3984                         dirlen = 0;
3985                     }
3986
3987                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
3988                         continue;
3989 #ifdef VMS
3990                     if ((unixdir =
3991                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3992                          == NULL)
3993                         continue;
3994                     sv_setpv(namesv, unixdir);
3995                     sv_catpv(namesv, unixname);
3996 #else
3997 #  ifdef __SYMBIAN32__
3998                     if (PL_origfilename[0] &&
3999                         PL_origfilename[1] == ':' &&
4000                         !(dir[0] && dir[1] == ':'))
4001                         Perl_sv_setpvf(aTHX_ namesv,
4002                                        "%c:%s\\%s",
4003                                        PL_origfilename[0],
4004                                        dir, name);
4005                     else
4006                         Perl_sv_setpvf(aTHX_ namesv,
4007                                        "%s\\%s",
4008                                        dir, name);
4009 #  else
4010                     /* The equivalent of
4011                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4012                        but without the need to parse the format string, or
4013                        call strlen on either pointer, and with the correct
4014                        allocation up front.  */
4015                     {
4016                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4017
4018                         memcpy(tmp, dir, dirlen);
4019                         tmp +=dirlen;
4020
4021                         /* Avoid '<dir>//<file>' */
4022                         if (!dirlen || *(tmp-1) != '/') {
4023                             *tmp++ = '/';
4024                         } else {
4025                             /* So SvCUR_set reports the correct length below */
4026                             dirlen--;
4027                         }
4028
4029                         /* name came from an SV, so it will have a '\0' at the
4030                            end that we can copy as part of this memcpy().  */
4031                         memcpy(tmp, name, len + 1);
4032
4033                         SvCUR_set(namesv, dirlen + len + 1);
4034                         SvPOK_on(namesv);
4035                     }
4036 #  endif
4037 #endif
4038                     TAINT_PROPER(op_name);
4039                     tryname = SvPVX_const(namesv);
4040                     tryrsfp = doopen_pm(namesv);
4041                     if (tryrsfp) {
4042                         if (tryname[0] == '.' && tryname[1] == '/') {
4043                             ++tryname;
4044                             while (*++tryname == '/') {}
4045                         }
4046                         break;
4047                     }
4048                     else if (errno == EMFILE || errno == EACCES) {
4049                         /* no point in trying other paths if out of handles;
4050                          * on the other hand, if we couldn't open one of the
4051                          * files, then going on with the search could lead to
4052                          * unexpected results; see perl #113422
4053                          */
4054                         break;
4055                     }
4056                   }
4057                 }
4058             }
4059         }
4060     }
4061     saved_errno = errno; /* sv_2mortal can realloc things */
4062     sv_2mortal(namesv);
4063     if (!tryrsfp) {
4064         if (op_is_require) {
4065             if(saved_errno == EMFILE || saved_errno == EACCES) {
4066                 /* diag_listed_as: Can't locate %s */
4067                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4068                     name, tryname, Strerror(saved_errno));
4069             } else {
4070                 if (namesv) {                   /* did we lookup @INC? */
4071                     AV * const ar = GvAVn(PL_incgv);
4072                     SSize_t i;
4073                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4074                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4075                     for (i = 0; i <= AvFILL(ar); i++) {
4076                         sv_catpvs(inc, " ");
4077                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4078                     }
4079                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4080                         const char *c, *e = name + len - 3;
4081                         sv_catpv(msg, " (you may need to install the ");
4082                         for (c = name; c < e; c++) {
4083                             if (*c == '/') {
4084                                 sv_catpvs(msg, "::");
4085                             }
4086                             else {
4087                                 sv_catpvn(msg, c, 1);
4088                             }
4089                         }
4090                         sv_catpv(msg, " module)");
4091                     }
4092                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4093                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4094                     }
4095                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4096                         sv_catpv(msg, " (did you run h2ph?)");
4097                     }
4098
4099                     /* diag_listed_as: Can't locate %s */
4100                     DIE(aTHX_
4101                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4102                         name, msg, inc);
4103                 }
4104             }
4105             DIE(aTHX_ "Can't locate %s", name);
4106         }
4107
4108         CLEAR_ERRSV();
4109         RETPUSHUNDEF;
4110     }
4111     else
4112         SETERRNO(0, SS_NORMAL);
4113
4114     /* Assume success here to prevent recursive requirement. */
4115     /* name is never assigned to again, so len is still strlen(name)  */
4116     /* Check whether a hook in @INC has already filled %INC */
4117     if (!hook_sv) {
4118         (void)hv_store(GvHVn(PL_incgv),
4119                        unixname, unixlen, newSVpv(tryname,0),0);
4120     } else {
4121         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4122         if (!svp)
4123             (void)hv_store(GvHVn(PL_incgv),
4124                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4125     }
4126
4127     old_savestack_ix = PL_savestack_ix;
4128     SAVECOPFILE_FREE(&PL_compiling);
4129     CopFILE_set(&PL_compiling, tryname);
4130     lex_start(NULL, tryrsfp, 0);
4131
4132     if (filter_sub || filter_cache) {
4133         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4134            than hanging another SV from it. In turn, filter_add() optionally
4135            takes the SV to use as the filter (or creates a new SV if passed
4136            NULL), so simply pass in whatever value filter_cache has.  */
4137         SV * const fc = filter_cache ? newSV(0) : NULL;
4138         SV *datasv;
4139         if (fc) sv_copypv(fc, filter_cache);
4140         datasv = filter_add(S_run_user_filter, fc);
4141         IoLINES(datasv) = filter_has_file;
4142         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4143         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4144     }
4145
4146     /* switch to eval mode */
4147     cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4148     cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4149
4150     SAVECOPLINE(&PL_compiling);
4151     CopLINE_set(&PL_compiling, 0);
4152
4153     PUTBACK;
4154
4155     if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4156         op = DOCATCH(PL_eval_start);
4157     else
4158         op = PL_op->op_next;
4159
4160     PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4161
4162     return op;
4163 }
4164
4165
4166 /* also used for: pp_dofile() */
4167
4168 PP(pp_require)
4169 {
4170     dSP;
4171     SV *sv = POPs;
4172     SvGETMAGIC(sv);
4173     PUTBACK;
4174     return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4175         ? S_require_version(aTHX_ sv)
4176         : S_require_file(aTHX_ sv);
4177 }
4178
4179
4180 /* This is a op added to hold the hints hash for
4181    pp_entereval. The hash can be modified by the code
4182    being eval'ed, so we return a copy instead. */
4183
4184 PP(pp_hintseval)
4185 {
4186     dSP;
4187     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4188     RETURN;
4189 }
4190
4191
4192 PP(pp_entereval)
4193 {
4194     dSP;
4195     PERL_CONTEXT *cx;
4196     SV *sv;
4197     const U8 gimme = GIMME_V;
4198     const U32 was = PL_breakable_sub_gen;
4199     char tbuf[TYPE_DIGITS(long) + 12];
4200     bool saved_delete = FALSE;
4201     char *tmpbuf = tbuf;
4202     STRLEN len;
4203     CV* runcv;
4204     U32 seq, lex_flags = 0;
4205     HV *saved_hh = NULL;
4206     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4207     I32 old_savestack_ix;
4208
4209     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4210         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4211     }
4212     else if (PL_hints & HINT_LOCALIZE_HH || (
4213                 PL_op->op_private & OPpEVAL_COPHH
4214              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4215             )) {
4216         saved_hh = cop_hints_2hv(PL_curcop, 0);
4217         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4218     }
4219     sv = POPs;
4220     if (!SvPOK(sv)) {
4221         /* make sure we've got a plain PV (no overload etc) before testing
4222          * for taint. Making a copy here is probably overkill, but better
4223          * safe than sorry */
4224         STRLEN len;
4225         const char * const p = SvPV_const(sv, len);
4226
4227         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4228         lex_flags |= LEX_START_COPIED;
4229
4230         if (bytes && SvUTF8(sv))
4231             SvPVbyte_force(sv, len);
4232     }
4233     else if (bytes && SvUTF8(sv)) {
4234         /* Don't modify someone else's scalar */
4235         STRLEN len;
4236         sv = newSVsv(sv);
4237         (void)sv_2mortal(sv);
4238         SvPVbyte_force(sv,len);
4239         lex_flags |= LEX_START_COPIED;
4240     }
4241
4242     TAINT_IF(SvTAINTED(sv));
4243     TAINT_PROPER("eval");
4244
4245     old_savestack_ix = PL_savestack_ix;
4246
4247     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4248                            ? LEX_IGNORE_UTF8_HINTS
4249                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4250                         )
4251              );
4252
4253     /* switch to eval mode */
4254
4255     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4256         SV * const temp_sv = sv_newmortal();
4257         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4258                        (unsigned long)++PL_evalseq,
4259                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4260         tmpbuf = SvPVX(temp_sv);
4261         len = SvCUR(temp_sv);
4262     }
4263     else
4264         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4265     SAVECOPFILE_FREE(&PL_compiling);
4266     CopFILE_set(&PL_compiling, tmpbuf+2);
4267     SAVECOPLINE(&PL_compiling);
4268     CopLINE_set(&PL_compiling, 1);
4269     /* special case: an eval '' executed within the DB package gets lexically
4270      * placed in the first non-DB CV rather than the current CV - this
4271      * allows the debugger to execute code, find lexicals etc, in the
4272      * scope of the code being debugged. Passing &seq gets find_runcv
4273      * to do the dirty work for us */
4274     runcv = find_runcv(&seq);
4275
4276     cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4277     cx_pusheval(cx, PL_op->op_next, NULL);
4278
4279     /* prepare to compile string */
4280
4281     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4282         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4283     else {
4284         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4285            deleting the eval's FILEGV from the stash before gv_check() runs
4286            (i.e. before run-time proper). To work around the coredump that
4287            ensues, we always turn GvMULTI_on for any globals that were
4288            introduced within evals. See force_ident(). GSAR 96-10-12 */
4289         char *const safestr = savepvn(tmpbuf, len);
4290         SAVEDELETE(PL_defstash, safestr, len);
4291         saved_delete = TRUE;
4292     }
4293
4294     PUTBACK;
4295
4296     if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4297         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4298             ?  PERLDB_LINE_OR_SAVESRC
4299             :  PERLDB_SAVESRC_NOSUBS) {
4300             /* Retain the filegv we created.  */
4301         } else if (!saved_delete) {
4302             char *const safestr = savepvn(tmpbuf, len);
4303             SAVEDELETE(PL_defstash, safestr, len);
4304         }
4305         return DOCATCH(PL_eval_start);
4306     } else {
4307         /* We have already left the scope set up earlier thanks to the LEAVE
4308            in doeval_compile().  */
4309         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4310             ?  PERLDB_LINE_OR_SAVESRC
4311             :  PERLDB_SAVESRC_INVALID) {
4312             /* Retain the filegv we created.  */
4313         } else if (!saved_delete) {
4314             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4315         }
4316         return PL_op->op_next;
4317     }
4318 }
4319
4320
4321 /* also tail-called by pp_return */
4322
4323 PP(pp_leaveeval)
4324 {
4325     SV **oldsp;
4326     U8 gimme;
4327     PERL_CONTEXT *cx;
4328     OP *retop;
4329     int failed;
4330     CV *evalcv;
4331     bool keep;
4332
4333     PERL_ASYNC_CHECK();
4334
4335     cx = CX_CUR();
4336     assert(CxTYPE(cx) == CXt_EVAL);
4337
4338     oldsp = PL_stack_base + cx->blk_oldsp;
4339     gimme = cx->blk_gimme;
4340
4341     /* did require return a false value? */
4342     failed =    CxOLD_OP_TYPE(cx) == OP_REQUIRE
4343              && !(gimme == G_SCALAR
4344                     ? SvTRUE(*PL_stack_sp)
4345                     : PL_stack_sp > oldsp);
4346
4347     if (gimme == G_VOID)
4348         PL_stack_sp = oldsp;
4349     else
4350         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4351
4352     /* the cx_popeval does a leavescope, which frees the optree associated
4353      * with eval, which if it frees the nextstate associated with
4354      * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4355      * regex when running under 'use re Debug' because it needs PL_curcop
4356      * to get the current hints. So restore it early.
4357      */
4358     PL_curcop = cx->blk_oldcop;
4359
4360     /* grab this value before cx_popeval restores the old PL_in_eval */
4361     keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4362     retop = cx->blk_eval.retop;
4363     evalcv = cx->blk_eval.cv;
4364 #ifdef DEBUGGING
4365     assert(CvDEPTH(evalcv) == 1);
4366 #endif
4367     CvDEPTH(evalcv) = 0;
4368
4369     /* pop the CXt_EVAL, and if a require failed, croak */
4370     S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4371
4372     if (!keep)
4373         CLEAR_ERRSV();
4374
4375     return retop;
4376 }
4377
4378 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4379    close to the related Perl_create_eval_scope.  */
4380 void
4381 Perl_delete_eval_scope(pTHX)
4382 {
4383     PERL_CONTEXT *cx;
4384
4385     cx = CX_CUR();
4386     CX_LEAVE_SCOPE(cx);
4387     cx_popeval(cx);
4388     cx_popblock(cx);
4389     CX_POP(cx);
4390 }
4391
4392 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4393    also needed by Perl_fold_constants.  */
4394 void
4395 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4396 {
4397     PERL_CONTEXT *cx;
4398     const U8 gimme = GIMME_V;
4399
4400     cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4401                     PL_stack_sp, PL_savestack_ix);
4402     cx_pusheval(cx, retop, NULL);
4403
4404     PL_in_eval = EVAL_INEVAL;
4405     if (flags & G_KEEPERR)
4406         PL_in_eval |= EVAL_KEEPERR;
4407     else
4408         CLEAR_ERRSV();
4409     if (flags & G_FAKINGEVAL) {
4410         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4411     }
4412 }
4413
4414 PP(pp_entertry)
4415 {
4416     create_eval_scope(cLOGOP->op_other->op_next, 0);
4417     return DOCATCH(PL_op->op_next);
4418 }
4419
4420
4421 /* also tail-called by pp_return */
4422
4423 PP(pp_leavetry)
4424 {
4425     SV **oldsp;
4426     U8 gimme;
4427     PERL_CONTEXT *cx;
4428     OP *retop;
4429
4430     PERL_ASYNC_CHECK();
4431
4432     cx = CX_CUR();
4433     assert(CxTYPE(cx) == CXt_EVAL);
4434     oldsp = PL_stack_base + cx->blk_oldsp;
4435     gimme = cx->blk_gimme;
4436
4437     if (gimme == G_VOID)
4438         PL_stack_sp = oldsp;
4439     else
4440         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4441     CX_LEAVE_SCOPE(cx);
4442     cx_popeval(cx);
4443     cx_popblock(cx);
4444     retop = cx->blk_eval.retop;
4445     CX_POP(cx);
4446
4447     CLEAR_ERRSV();
4448     return retop;
4449 }
4450
4451 PP(pp_entergiven)
4452 {
4453     dSP;
4454     PERL_CONTEXT *cx;
4455     const U8 gimme = GIMME_V;
4456     SV *origsv = DEFSV;
4457     SV *newsv = POPs;
4458
4459     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4460     GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4461
4462     cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4463     cx_pushgiven(cx, origsv);
4464
4465     RETURN;
4466 }
4467
4468 PP(pp_leavegiven)
4469 {
4470     PERL_CONTEXT *cx;
4471     U8 gimme;
4472     SV **oldsp;
4473     PERL_UNUSED_CONTEXT;
4474
4475     cx = CX_CUR();
4476     assert(CxTYPE(cx) == CXt_GIVEN);
4477     oldsp = PL_stack_base + cx->blk_oldsp;
4478     gimme = cx->blk_gimme;
4479
4480     if (gimme == G_VOID)
4481         PL_stack_sp = oldsp;
4482     else
4483         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4484
4485     CX_LEAVE_SCOPE(cx);
4486     cx_popgiven(cx);
4487     cx_popblock(cx);
4488     CX_POP(cx);
4489
4490     return NORMAL;
4491 }
4492
4493 /* Helper routines used by pp_smartmatch */
4494 STATIC PMOP *
4495 S_make_matcher(pTHX_ REGEXP *re)
4496 {
4497     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4498
4499     PERL_ARGS_ASSERT_MAKE_MATCHER;
4500
4501     PM_SETRE(matcher, ReREFCNT_inc(re));
4502
4503     SAVEFREEOP((OP *) matcher);
4504     ENTER_with_name("matcher"); SAVETMPS;
4505     SAVEOP();
4506     return matcher;
4507 }
4508
4509 STATIC bool
4510 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4511 {
4512     dSP;
4513     bool result;
4514
4515     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4516
4517     PL_op = (OP *) matcher;
4518     XPUSHs(sv);
4519     PUTBACK;
4520     (void) Perl_pp_match(aTHX);
4521     SPAGAIN;
4522     result = SvTRUEx(POPs);
4523     PUTBACK;
4524
4525     return result;
4526 }
4527
4528 STATIC void
4529 S_destroy_matcher(pTHX_ PMOP *matcher)
4530 {
4531     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4532     PERL_UNUSED_ARG(matcher);
4533
4534     FREETMPS;
4535     LEAVE_with_name("matcher");
4536 }
4537
4538 /* Do a smart match */
4539 PP(pp_smartmatch)
4540 {
4541     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4542     return do_smartmatch(NULL, NULL, 0);
4543 }
4544
4545 /* This version of do_smartmatch() implements the
4546  * table of smart matches that is found in perlsyn.
4547  */
4548 STATIC OP *
4549 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4550 {
4551     dSP;
4552
4553     bool object_on_left = FALSE;
4554     SV *e = TOPs;       /* e is for 'expression' */
4555     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4556
4557     /* Take care only to invoke mg_get() once for each argument.
4558      * Currently we do this by copying the SV if it's magical. */
4559     if (d) {
4560         if (!copied && SvGMAGICAL(d))
4561             d = sv_mortalcopy(d);
4562     }
4563     else
4564         d = &PL_sv_undef;
4565
4566     assert(e);
4567     if (SvGMAGICAL(e))
4568         e = sv_mortalcopy(e);
4569
4570     /* First of all, handle overload magic of the rightmost argument */
4571     if (SvAMAGIC(e)) {
4572         SV * tmpsv;
4573         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4574         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4575
4576         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4577         if (tmpsv) {
4578             SPAGAIN;
4579             (void)POPs;
4580             SETs(tmpsv);
4581             RETURN;
4582         }
4583         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4584     }
4585
4586     SP -= 2;    /* Pop the values */
4587     PUTBACK;
4588
4589     /* ~~ undef */
4590     if (!SvOK(e)) {
4591         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4592         if (SvOK(d))
4593             RETPUSHNO;
4594         else
4595             RETPUSHYES;
4596     }
4597
4598     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4599         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4600         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4601     }
4602     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4603         object_on_left = TRUE;
4604
4605     /* ~~ sub */
4606     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4607         I32 c;
4608         if (object_on_left) {
4609             goto sm_any_sub; /* Treat objects like scalars */
4610         }
4611         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4612             /* Test sub truth for each key */
4613             HE *he;
4614             bool andedresults = TRUE;
4615             HV *hv = (HV*) SvRV(d);
4616             I32 numkeys = hv_iterinit(hv);
4617             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4618             if (numkeys == 0)
4619                 RETPUSHYES;
4620             while ( (he = hv_iternext(hv)) ) {
4621                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4622                 ENTER_with_name("smartmatch_hash_key_test");
4623                 SAVETMPS;
4624                 PUSHMARK(SP);
4625                 PUSHs(hv_iterkeysv(he));
4626                 PUTBACK;
4627                 c = call_sv(e, G_SCALAR);
4628                 SPAGAIN;
4629                 if (c == 0)
4630                     andedresults = FALSE;
4631                 else
4632                     andedresults = SvTRUEx(POPs) && andedresults;
4633                 FREETMPS;
4634                 LEAVE_with_name("smartmatch_hash_key_test");
4635             }
4636             if (andedresults)
4637                 RETPUSHYES;
4638             else
4639                 RETPUSHNO;
4640         }
4641         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4642             /* Test sub truth for each element */
4643             SSize_t i;
4644             bool andedresults = TRUE;
4645             AV *av = (AV*) SvRV(d);
4646             const I32 len = av_tindex(av);
4647             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4648             if (len == -1)
4649                 RETPUSHYES;
4650             for (i = 0; i <= len; ++i) {
4651                 SV * const * const svp = av_fetch(av, i, FALSE);
4652                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4653                 ENTER_with_name("smartmatch_array_elem_test");
4654                 SAVETMPS;
4655                 PUSHMARK(SP);
4656                 if (svp)
4657                     PUSHs(*svp);
4658                 PUTBACK;
4659                 c = call_sv(e, G_SCALAR);
4660                 SPAGAIN;
4661                 if (c == 0)
4662                     andedresults = FALSE;
4663                 else
4664                     andedresults = SvTRUEx(POPs) && andedresults;
4665                 FREETMPS;
4666                 LEAVE_with_name("smartmatch_array_elem_test");
4667             }
4668             if (andedresults)
4669                 RETPUSHYES;
4670             else
4671                 RETPUSHNO;
4672         }
4673         else {
4674           sm_any_sub:
4675             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4676             ENTER_with_name("smartmatch_coderef");
4677             SAVETMPS;
4678             PUSHMARK(SP);
4679             PUSHs(d);
4680             PUTBACK;
4681             c = call_sv(e, G_SCALAR);
4682             SPAGAIN;
4683             if (c == 0)
4684                 PUSHs(&PL_sv_no);
4685             else if (SvTEMP(TOPs))
4686                 SvREFCNT_inc_void(TOPs);
4687             FREETMPS;
4688             LEAVE_with_name("smartmatch_coderef");
4689             RETURN;
4690         }
4691     }
4692     /* ~~ %hash */
4693     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4694         if (object_on_left) {
4695             goto sm_any_hash; /* Treat objects like scalars */
4696         }
4697         else if (!SvOK(d)) {
4698             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4699             RETPUSHNO;
4700         }
4701         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4702             /* Check that the key-sets are identical */
4703             HE *he;
4704             HV *other_hv = MUTABLE_HV(SvRV(d));
4705             bool tied;
4706             bool other_tied;
4707             U32 this_key_count  = 0,
4708                 other_key_count = 0;
4709             HV *hv = MUTABLE_HV(SvRV(e));
4710
4711             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4712             /* Tied hashes don't know how many keys they have. */
4713             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4714             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4715             if (!tied ) {
4716                 if(other_tied) {
4717                     /* swap HV sides */
4718                     HV * const temp = other_hv;
4719                     other_hv = hv;
4720                     hv = temp;
4721                     tied = TRUE;
4722                     other_tied = FALSE;
4723                 }
4724                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4725                     RETPUSHNO;
4726             }
4727
4728             /* The hashes have the same number of keys, so it suffices
4729                to check that one is a subset of the other. */
4730             (void) hv_iterinit(hv);
4731             while ( (he = hv_iternext(hv)) ) {
4732                 SV *key = hv_iterkeysv(he);
4733
4734                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4735                 ++ this_key_count;
4736
4737                 if(!hv_exists_ent(other_hv, key, 0)) {
4738                     (void) hv_iterinit(hv);     /* reset iterator */
4739                     RETPUSHNO;
4740                 }
4741             }
4742
4743             if (other_tied) {
4744                 (void) hv_iterinit(other_hv);
4745                 while ( hv_iternext(other_hv) )
4746                     ++other_key_count;
4747             }
4748             else
4749                 other_key_count = HvUSEDKEYS(other_hv);
4750
4751             if (this_key_count != other_key_count)
4752                 RETPUSHNO;
4753             else
4754                 RETPUSHYES;
4755         }
4756         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4757             AV * const other_av = MUTABLE_AV(SvRV(d));
4758             const SSize_t other_len = av_tindex(other_av) + 1;
4759             SSize_t i;
4760             HV *hv = MUTABLE_HV(SvRV(e));
4761
4762             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4763             for (i = 0; i < other_len; ++i) {
4764                 SV ** const svp = av_fetch(other_av, i, FALSE);
4765                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4766                 if (svp) {      /* ??? When can this not happen? */
4767                     if (hv_exists_ent(hv, *svp, 0))
4768                         RETPUSHYES;
4769                 }
4770             }
4771             RETPUSHNO;
4772         }
4773         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4774             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4775           sm_regex_hash:
4776             {
4777                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4778                 HE *he;
4779                 HV *hv = MUTABLE_HV(SvRV(e));
4780
4781                 (void) hv_iterinit(hv);
4782                 while ( (he = hv_iternext(hv)) ) {
4783                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4784                     PUTBACK;
4785                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4786                         SPAGAIN;
4787                         (void) hv_iterinit(hv);
4788                         destroy_matcher(matcher);
4789                         RETPUSHYES;
4790                     }
4791                     SPAGAIN;
4792                 }
4793                 destroy_matcher(matcher);
4794                 RETPUSHNO;
4795             }
4796         }
4797         else {
4798           sm_any_hash:
4799             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4800             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4801                 RETPUSHYES;
4802             else
4803                 RETPUSHNO;
4804         }
4805     }
4806     /* ~~ @array */
4807     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4808         if (object_on_left) {
4809             goto sm_any_array; /* Treat objects like scalars */
4810         }
4811         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4812             AV * const other_av = MUTABLE_AV(SvRV(e));
4813             const SSize_t other_len = av_tindex(other_av) + 1;
4814             SSize_t i;
4815
4816             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4817             for (i = 0; i < other_len; ++i) {
4818                 SV ** const svp = av_fetch(other_av, i, FALSE);
4819
4820                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4821                 if (svp) {      /* ??? When can this not happen? */
4822                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4823                         RETPUSHYES;
4824                 }
4825             }
4826             RETPUSHNO;
4827         }
4828         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4829             AV *other_av = MUTABLE_AV(SvRV(d));
4830             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4831             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4832                 RETPUSHNO;
4833             else {
4834                 SSize_t i;
4835                 const SSize_t other_len = av_tindex(other_av);
4836
4837                 if (NULL == seen_this) {
4838                     seen_this = newHV();
4839                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4840                 }
4841                 if (NULL == seen_other) {
4842                     seen_other = newHV();
4843                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4844                 }
4845                 for(i = 0; i <= other_len; ++i) {
4846                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4847                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4848
4849                     if (!this_elem || !other_elem) {
4850                         if ((this_elem && SvOK(*this_elem))
4851                                 || (other_elem && SvOK(*other_elem)))
4852                             RETPUSHNO;
4853                     }
4854                     else if (hv_exists_ent(seen_this,
4855                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4856                             hv_exists_ent(seen_other,
4857                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4858                     {
4859                         if (*this_elem != *other_elem)
4860                             RETPUSHNO;
4861                     }
4862                     else {
4863                         (void)hv_store_ent(seen_this,
4864                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4865                                 &PL_sv_undef, 0);
4866                         (void)hv_store_ent(seen_other,
4867                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4868                                 &PL_sv_undef, 0);
4869                         PUSHs(*other_elem);
4870                         PUSHs(*this_elem);
4871
4872                         PUTBACK;
4873                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4874                         (void) do_smartmatch(seen_this, seen_other, 0);
4875                         SPAGAIN;
4876                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4877
4878                         if (!SvTRUEx(POPs))
4879                             RETPUSHNO;
4880                     }
4881                 }
4882                 RETPUSHYES;
4883             }
4884         }
4885         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4886             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4887           sm_regex_array:
4888             {
4889                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4890                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4891                 SSize_t i;
4892
4893                 for(i = 0; i <= this_len; ++i) {
4894                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4895                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4896                     PUTBACK;
4897                     if (svp && matcher_matches_sv(matcher, *svp)) {
4898                         SPAGAIN;
4899                         destroy_matcher(matcher);
4900                         RETPUSHYES;
4901                     }
4902                     SPAGAIN;
4903                 }
4904                 destroy_matcher(matcher);
4905                 RETPUSHNO;
4906             }
4907         }
4908         else if (!SvOK(d)) {
4909             /* undef ~~ array */
4910             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4911             SSize_t i;
4912
4913             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4914             for (i = 0; i <= this_len; ++i) {
4915                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4916                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4917                 if (!svp || !SvOK(*svp))
4918                     RETPUSHYES;
4919             }
4920             RETPUSHNO;
4921         }
4922         else {
4923           sm_any_array:
4924             {
4925                 SSize_t i;
4926                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4927
4928                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4929                 for (i = 0; i <= this_len; ++i) {
4930                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4931                     if (!svp)
4932                         continue;
4933
4934                     PUSHs(d);
4935                     PUSHs(*svp);
4936                     PUTBACK;
4937                     /* infinite recursion isn't supposed to happen here */
4938                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4939                     (void) do_smartmatch(NULL, NULL, 1);
4940                     SPAGAIN;
4941                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4942                     if (SvTRUEx(POPs))
4943                         RETPUSHYES;
4944                 }
4945                 RETPUSHNO;
4946             }
4947         }
4948     }
4949     /* ~~ qr// */
4950     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4951         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4952             SV *t = d; d = e; e = t;
4953             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4954             goto sm_regex_hash;
4955         }
4956         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4957             SV *t = d; d = e; e = t;
4958             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4959             goto sm_regex_array;
4960         }
4961         else {
4962             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4963             bool result;
4964
4965             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4966             PUTBACK;
4967             result = matcher_matches_sv(matcher, d);
4968             SPAGAIN;
4969             PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4970             destroy_matcher(matcher);
4971             RETURN;
4972         }
4973     }
4974     /* ~~ scalar */
4975     /* See if there is overload magic on left */
4976     else if (object_on_left && SvAMAGIC(d)) {
4977         SV *tmpsv;
4978         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4979         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4980         PUSHs(d); PUSHs(e);
4981         PUTBACK;
4982         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4983         if (tmpsv) {
4984             SPAGAIN;
4985             (void)POPs;
4986             SETs(tmpsv);
4987             RETURN;
4988         }
4989         SP -= 2;
4990         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4991         goto sm_any_scalar;
4992     }
4993     else if (!SvOK(d)) {
4994         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4995         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4996         RETPUSHNO;
4997     }
4998     else
4999   sm_any_scalar:
5000     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5001         DEBUG_M(if (SvNIOK(e))
5002                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
5003                 else
5004                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
5005         );
5006         /* numeric comparison */
5007         PUSHs(d); PUSHs(e);
5008         PUTBACK;
5009         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5010             (void) Perl_pp_i_eq(aTHX);
5011         else
5012             (void) Perl_pp_eq(aTHX);
5013         SPAGAIN;
5014         if (SvTRUEx(POPs))
5015             RETPUSHYES;
5016         else
5017             RETPUSHNO;
5018     }
5019
5020     /* As a last resort, use string comparison */
5021     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
5022     PUSHs(d); PUSHs(e);
5023     PUTBACK;
5024     return Perl_pp_seq(aTHX);
5025 }
5026
5027 PP(pp_enterwhen)
5028 {
5029     dSP;
5030     PERL_CONTEXT *cx;
5031     const U8 gimme = GIMME_V;
5032
5033     /* This is essentially an optimization: if the match
5034        fails, we don't want to push a context and then
5035        pop it again right away, so we skip straight
5036        to the op that follows the leavewhen.
5037        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5038     */
5039     if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
5040         RETURNOP(cLOGOP->op_other->op_next);
5041
5042     cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5043     cx_pushwhen(cx);
5044
5045     RETURN;
5046 }
5047
5048 PP(pp_leavewhen)
5049 {
5050     I32 cxix;
5051     PERL_CONTEXT *cx;
5052     U8 gimme;
5053     SV **oldsp;
5054
5055     cx = CX_CUR();
5056     assert(CxTYPE(cx) == CXt_WHEN);
5057     gimme = cx->blk_gimme;
5058
5059     cxix = dopoptogivenfor(cxstack_ix);
5060     if (cxix < 0)
5061         /* diag_listed_as: Can't "when" outside a topicalizer */
5062         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5063                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5064
5065     oldsp = PL_stack_base + cx->blk_oldsp;
5066     if (gimme == G_VOID)
5067         PL_stack_sp = oldsp;
5068     else
5069         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5070
5071     /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5072     assert(cxix < cxstack_ix);
5073     dounwind(cxix);
5074
5075     cx = &cxstack[cxix];
5076
5077     if (CxFOREACH(cx)) {
5078         /* emulate pp_next. Note that any stack(s) cleanup will be
5079          * done by the pp_unstack which op_nextop should point to */
5080         cx = CX_CUR();
5081         cx_topblock(cx);
5082         PL_curcop = cx->blk_oldcop;
5083         return cx->blk_loop.my_op->op_nextop;
5084     }
5085     else {
5086         PERL_ASYNC_CHECK();
5087         assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5088         return cx->blk_givwhen.leave_op;
5089     }
5090 }
5091
5092 PP(pp_continue)
5093 {
5094     I32 cxix;
5095     PERL_CONTEXT *cx;
5096     OP *nextop;
5097
5098     cxix = dopoptowhen(cxstack_ix);
5099     if (cxix < 0)
5100         DIE(aTHX_ "Can't \"continue\" outside a when block");
5101
5102     if (cxix < cxstack_ix)
5103         dounwind(cxix);
5104
5105     cx = CX_CUR();
5106     assert(CxTYPE(cx) == CXt_WHEN);
5107     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5108     CX_LEAVE_SCOPE(cx);
5109     cx_popwhen(cx);
5110     cx_popblock(cx);
5111     nextop = cx->blk_givwhen.leave_op->op_next;
5112     CX_POP(cx);
5113
5114     return nextop;
5115 }
5116
5117 PP(pp_break)
5118 {
5119     I32 cxix;
5120     PERL_CONTEXT *cx;
5121
5122     cxix = dopoptogivenfor(cxstack_ix);
5123     if (cxix < 0)
5124         DIE(aTHX_ "Can't \"break\" outside a given block");
5125
5126     cx = &cxstack[cxix];
5127     if (CxFOREACH(cx))
5128         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5129
5130     if (cxix < cxstack_ix)
5131         dounwind(cxix);
5132
5133     /* Restore the sp at the time we entered the given block */
5134     cx = CX_CUR();
5135     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5136
5137     return cx->blk_givwhen.leave_op;
5138 }
5139
5140 static MAGIC *
5141 S_doparseform(pTHX_ SV *sv)
5142 {
5143     STRLEN len;
5144     char *s = SvPV(sv, len);
5145     char *send;
5146     char *base = NULL; /* start of current field */
5147     I32 skipspaces = 0; /* number of contiguous spaces seen */
5148     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5149     bool repeat    = FALSE; /* ~~ seen on this line */
5150     bool postspace = FALSE; /* a text field may need right padding */
5151     U32 *fops;
5152     U32 *fpc;
5153     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5154     I32 arg;
5155     bool ischop;            /* it's a ^ rather than a @ */
5156     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5157     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5158     MAGIC *mg = NULL;
5159     SV *sv_copy;
5160
5161     PERL_ARGS_ASSERT_DOPARSEFORM;
5162
5163     if (len == 0)
5164         Perl_croak(aTHX_ "Null picture in formline");
5165
5166     if (SvTYPE(sv) >= SVt_PVMG) {
5167         /* This might, of course, still return NULL.  */
5168         mg = mg_find(sv, PERL_MAGIC_fm);
5169     } else {
5170         sv_upgrade(sv, SVt_PVMG);
5171     }
5172
5173     if (mg) {
5174         /* still the same as previously-compiled string? */
5175         SV *old = mg->mg_obj;
5176         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5177               && len == SvCUR(old)
5178               && strnEQ(SvPVX(old), s, len)
5179         ) {
5180             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5181             return mg;
5182         }
5183
5184         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5185         Safefree(mg->mg_ptr);
5186         mg->mg_ptr = NULL;
5187         SvREFCNT_dec(old);
5188         mg->mg_obj = NULL;
5189     }
5190     else {
5191         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5192         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5193     }
5194
5195     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5196     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5197     send = s + len;
5198
5199
5200     /* estimate the buffer size needed */
5201     for (base = s; s <= send; s++) {
5202         if (*s == '\n' || *s == '@' || *s == '^')
5203             maxops += 10;
5204     }
5205     s = base;
5206     base = NULL;
5207
5208     Newx(fops, maxops, U32);
5209     fpc = fops;
5210
5211     if (s < send) {
5212         linepc = fpc;
5213         *fpc++ = FF_LINEMARK;
5214         noblank = repeat = FALSE;
5215         base = s;
5216     }
5217
5218     while (s <= send) {
5219         switch (*s++) {
5220         default:
5221             skipspaces = 0;
5222             continue;
5223
5224         case '~':
5225             if (*s == '~') {
5226                 repeat = TRUE;
5227                 skipspaces++;
5228                 s++;
5229             }
5230             noblank = TRUE;
5231             /* FALLTHROUGH */
5232         case ' ': case '\t':
5233             skipspaces++;
5234             continue;
5235         case 0:
5236             if (s < send) {
5237                 skipspaces = 0;
5238                 continue;
5239             } /* else FALL THROUGH */
5240         case '\n':
5241             arg = s - base;
5242             skipspaces++;
5243             arg -= skipspaces;
5244             if (arg) {
5245                 if (postspace)
5246                     *fpc++ = FF_SPACE;
5247                 *fpc++ = FF_LITERAL;
5248                 *fpc++ = (U32)arg;
5249             }
5250             postspace = FALSE;
5251             if (s <= send)
5252                 skipspaces--;
5253             if (skipspaces) {
5254                 *fpc++ = FF_SKIP;
5255                 *fpc++ = (U32)skipspaces;
5256             }
5257             skipspaces = 0;
5258             if (s <= send)
5259                 *fpc++ = FF_NEWLINE;
5260             if (noblank) {
5261                 *fpc++ = FF_BLANK;
5262                 if (repeat)
5263                     arg = fpc - linepc + 1;
5264                 else
5265                     arg = 0;
5266                 *fpc++ = (U32)arg;
5267             }
5268             if (s < send) {
5269                 linepc = fpc;
5270                 *fpc++ = FF_LINEMARK;
5271                 noblank = repeat = FALSE;
5272                 base = s;
5273             }
5274             else
5275                 s++;
5276             continue;
5277
5278         case '@':
5279         case '^':
5280             ischop = s[-1] == '^';
5281
5282             if (postspace) {
5283                 *fpc++ = FF_SPACE;
5284                 postspace = FALSE;
5285             }
5286             arg = (s - base) - 1;
5287             if (arg) {
5288                 *fpc++ = FF_LITERAL;
5289                 *fpc++ = (U32)arg;
5290             }
5291
5292             base = s - 1;
5293             *fpc++ = FF_FETCH;
5294             if (*s == '*') { /*  @* or ^*  */
5295                 s++;
5296                 *fpc++ = 2;  /* skip the @* or ^* */
5297                 if (ischop) {
5298                     *fpc++ = FF_LINESNGL;
5299                     *fpc++ = FF_CHOP;
5300                 } else
5301                     *fpc++ = FF_LINEGLOB;
5302             }
5303             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5304                 arg = ischop ? FORM_NUM_BLANK : 0;
5305                 base = s - 1;
5306                 while (*s == '#')
5307                     s++;
5308                 if (*s == '.') {
5309                     const char * const f = ++s;
5310                     while (*s == '#')
5311                         s++;
5312                     arg |= FORM_NUM_POINT + (s - f);
5313                 }
5314                 *fpc++ = s - base;              /* fieldsize for FETCH */
5315                 *fpc++ = FF_DECIMAL;
5316                 *fpc++ = (U32)arg;
5317                 unchopnum |= ! ischop;
5318             }
5319             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5320                 arg = ischop ? FORM_NUM_BLANK : 0;
5321                 base = s - 1;
5322                 s++;                                /* skip the '0' first */
5323                 while (*s == '#')
5324                     s++;
5325                 if (*s == '.') {
5326                     const char * const f = ++s;
5327                     while (*s == '#')
5328                         s++;
5329                     arg |= FORM_NUM_POINT + (s - f);
5330                 }
5331                 *fpc++ = s - base;                /* fieldsize for FETCH */
5332                 *fpc++ = FF_0DECIMAL;
5333                 *fpc++ = (U32)arg;
5334                 unchopnum |= ! ischop;
5335             }
5336             else {                              /* text field */
5337                 I32 prespace = 0;
5338                 bool ismore = FALSE;
5339
5340                 if (*s == '>') {
5341                     while (*++s == '>') ;
5342                     prespace = FF_SPACE;
5343                 }
5344                 else if (*s == '|') {
5345                     while (*++s == '|') ;
5346                     prespace = FF_HALFSPACE;
5347                     postspace = TRUE;
5348                 }
5349                 else {
5350                     if (*s == '<')
5351                         while (*++s == '<') ;
5352                     postspace = TRUE;
5353                 }
5354                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5355                     s += 3;
5356                     ismore = TRUE;
5357                 }
5358                 *fpc++ = s - base;              /* fieldsize for FETCH */
5359
5360                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5361
5362                 if (prespace)
5363                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5364                 *fpc++ = FF_ITEM;
5365                 if (ismore)
5366                     *fpc++ = FF_MORE;
5367                 if (ischop)
5368                     *fpc++ = FF_CHOP;
5369             }
5370             base = s;
5371             skipspaces = 0;
5372             continue;
5373         }
5374     }
5375     *fpc++ = FF_END;
5376
5377     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5378     arg = fpc - fops;
5379
5380     mg->mg_ptr = (char *) fops;
5381     mg->mg_len = arg * sizeof(U32);
5382     mg->mg_obj = sv_copy;
5383     mg->mg_flags |= MGf_REFCOUNTED;
5384
5385     if (unchopnum && repeat)
5386         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5387
5388     return mg;
5389 }
5390
5391
5392 STATIC bool
5393 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5394 {
5395     /* Can value be printed in fldsize chars, using %*.*f ? */
5396     NV pwr = 1;
5397     NV eps = 0.5;
5398     bool res = FALSE;
5399     int intsize = fldsize - (value < 0 ? 1 : 0);
5400
5401     if (frcsize & FORM_NUM_POINT)
5402         intsize--;
5403     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5404     intsize -= frcsize;
5405
5406     while (intsize--) pwr *= 10.0;
5407     while (frcsize--) eps /= 10.0;
5408
5409     if( value >= 0 ){
5410         if (value + eps >= pwr)
5411             res = TRUE;
5412     } else {
5413         if (value - eps <= -pwr)
5414             res = TRUE;
5415     }
5416     return res;
5417 }
5418
5419 static I32
5420 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5421 {
5422     SV * const datasv = FILTER_DATA(idx);
5423     const int filter_has_file = IoLINES(datasv);
5424     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5425     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5426     int status = 0;
5427     SV *upstream;
5428     STRLEN got_len;
5429     char *got_p = NULL;
5430     char *prune_from = NULL;
5431     bool read_from_cache = FALSE;
5432     STRLEN umaxlen;
5433     SV *err = NULL;
5434
5435     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5436
5437     assert(maxlen >= 0);
5438     umaxlen = maxlen;
5439
5440     /* I was having segfault trouble under Linux 2.2.5 after a
5441        parse error occurred.  (Had to hack around it with a test
5442        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5443        not sure where the trouble is yet.  XXX */
5444
5445     {
5446         SV *const cache = datasv;
5447         if (SvOK(cache)) {
5448             STRLEN cache_len;
5449             const char *cache_p = SvPV(cache, cache_len);
5450             STRLEN take = 0;
5451
5452             if (umaxlen) {
5453                 /* Running in block mode and we have some cached data already.
5454                  */
5455                 if (cache_len >= umaxlen) {
5456                     /* In fact, so much data we don't even need to call
5457                        filter_read.  */
5458                     take = umaxlen;
5459                 }
5460             } else {
5461                 const char *const first_nl =
5462                     (const char *)memchr(cache_p, '\n', cache_len);
5463                 if (first_nl) {
5464                     take = first_nl + 1 - cache_p;
5465                 }
5466             }
5467             if (take) {
5468                 sv_catpvn(buf_sv, cache_p, take);
5469                 sv_chop(cache, cache_p + take);
5470                 /* Definitely not EOF  */
5471                 return 1;
5472             }
5473
5474             sv_catsv(buf_sv, cache);
5475             if (umaxlen) {
5476                 umaxlen -= cache_len;
5477             }
5478             SvOK_off(cache);
5479             read_from_cache = TRUE;
5480         }
5481     }
5482
5483     /* Filter API says that the filter appends to the contents of the buffer.
5484        Usually the buffer is "", so the details don't matter. But if it's not,
5485        then clearly what it contains is already filtered by this filter, so we
5486        don't want to pass it in a second time.
5487        I'm going to use a mortal in case the upstream filter croaks.  */
5488     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5489         ? sv_newmortal() : buf_sv;
5490     SvUPGRADE(upstream, SVt_PV);
5491
5492     if (filter_has_file) {
5493         status = FILTER_READ(idx+1, upstream, 0);
5494     }
5495
5496     if (filter_sub && status >= 0) {
5497         dSP;
5498         int count;
5499
5500         ENTER_with_name("call_filter_sub");
5501         SAVE_DEFSV;
5502         SAVETMPS;
5503         EXTEND(SP, 2);
5504
5505         DEFSV_set(upstream);
5506         PUSHMARK(SP);
5507         mPUSHi(0);
5508         if (filter_state) {
5509             PUSHs(filter_state);
5510         }
5511         PUTBACK;
5512         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5513         SPAGAIN;
5514
5515         if (count > 0) {
5516             SV *out = POPs;
5517             SvGETMAGIC(out);
5518             if (SvOK(out)) {
5519                 status = SvIV(out);
5520             }
5521             else {
5522                 SV * const errsv = ERRSV;
5523                 if (SvTRUE_NN(errsv))
5524                     err = newSVsv(errsv);
5525             }
5526         }
5527
5528         PUTBACK;
5529         FREETMPS;
5530         LEAVE_with_name("call_filter_sub");
5531     }
5532
5533     if (SvGMAGICAL(upstream)) {
5534         mg_get(upstream);
5535         if (upstream == buf_sv) mg_free(buf_sv);
5536     }
5537     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5538     if(!err && SvOK(upstream)) {
5539         got_p = SvPV_nomg(upstream, got_len);
5540         if (umaxlen) {
5541             if (got_len > umaxlen) {
5542                 prune_from = got_p + umaxlen;
5543             }
5544         } else {
5545             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5546             if (first_nl && first_nl + 1 < got_p + got_len) {
5547                 /* There's a second line here... */
5548                 prune_from = first_nl + 1;
5549             }
5550         }
5551     }
5552     if (!err && prune_from) {
5553         /* Oh. Too long. Stuff some in our cache.  */
5554         STRLEN cached_len = got_p + got_len - prune_from;
5555         SV *const cache = datasv;
5556
5557         if (SvOK(cache)) {
5558             /* Cache should be empty.  */
5559             assert(!SvCUR(cache));
5560         }
5561
5562         sv_setpvn(cache, prune_from, cached_len);
5563         /* If you ask for block mode, you may well split UTF-8 characters.
5564            "If it breaks, you get to keep both parts"
5565            (Your code is broken if you  don't put them back together again
5566            before something notices.) */
5567         if (SvUTF8(upstream)) {
5568             SvUTF8_on(cache);
5569         }
5570         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5571         else
5572             /* Cannot just use sv_setpvn, as that could free the buffer
5573                before we have a chance to assign it. */
5574             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5575                       got_len - cached_len);
5576         *prune_from = 0;
5577         /* Can't yet be EOF  */
5578         if (status == 0)
5579             status = 1;
5580     }
5581
5582     /* If they are at EOF but buf_sv has something in it, then they may never
5583        have touched the SV upstream, so it may be undefined.  If we naively
5584        concatenate it then we get a warning about use of uninitialised value.
5585     */
5586     if (!err && upstream != buf_sv &&
5587         SvOK(upstream)) {
5588         sv_catsv_nomg(buf_sv, upstream);
5589     }
5590     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5591
5592     if (status <= 0) {
5593         IoLINES(datasv) = 0;
5594         if (filter_state) {
5595             SvREFCNT_dec(filter_state);
5596             IoTOP_GV(datasv) = NULL;
5597         }
5598         if (filter_sub) {
5599             SvREFCNT_dec(filter_sub);
5600             IoBOTTOM_GV(datasv) = NULL;
5601         }
5602         filter_del(S_run_user_filter);
5603     }
5604
5605     if (err)
5606         croak_sv(err);
5607
5608     if (status == 0 && read_from_cache) {
5609         /* If we read some data from the cache (and by getting here it implies
5610            that we emptied the cache) then we aren't yet at EOF, and mustn't
5611            report that to our caller.  */
5612         return 1;
5613     }
5614     return status;
5615 }
5616
5617 /*
5618  * ex: set ts=8 sts=4 sw=4 et:
5619  */