pp_ctl.c

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