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