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         if (SvTAINTED(TOPs))
 217             cx->sb_rxtainted |= SUBST_TAINT_REPL;
 218         sv_catsv_nomg(dstr, POPs);
 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(-Wformat-nonliteral);
 872                 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
 873                 GCC_DIAG_RESTORE;
 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 (strnEQ(s1,"   ",3)) {
 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_WHEN never actually needs "block" */
1289     NULL, /* CXt_BLOCK never actually needs "block" */
1290     NULL, /* CXt_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_PLAIN:
1324         case CXt_LOOP_LAZYIV:
1325         case CXt_LOOP_LAZYSV:
1326         case CXt_LOOP_LIST:
1327         case CXt_LOOP_ARY:
1328           {
1329             STRLEN cx_label_len = 0;
1330             U32 cx_label_flags = 0;
1331             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1332             if (!cx_label || !(
1333                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1334                         (flags & SVf_UTF8)
1335                             ? (bytes_cmp_utf8(
1336                                         (const U8*)cx_label, cx_label_len,
1337                                         (const U8*)label, len) == 0)
1338                             : (bytes_cmp_utf8(
1339                                         (const U8*)label, len,
1340                                         (const U8*)cx_label, cx_label_len) == 0)
1341                     : (len == cx_label_len && ((cx_label == label)
1342                                     || memEQ(cx_label, label, len))) )) {
1343                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1344                         (long)i, cx_label));
1345                 continue;
1346             }
1347             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1348             return i;
1349           }
1350         }
1351     }
1352     return i;
1353 }
1354
1355
1356
1357 U8
1358 Perl_dowantarray(pTHX)
1359 {
1360     const U8 gimme = block_gimme();
1361     return (gimme == G_VOID) ? G_SCALAR : gimme;
1362 }
1363
1364 U8
1365 Perl_block_gimme(pTHX)
1366 {
1367     const I32 cxix = dopoptosub(cxstack_ix);
1368     U8 gimme;
1369     if (cxix < 0)
1370         return G_VOID;
1371
1372     gimme = (cxstack[cxix].blk_gimme & G_WANT);
1373     if (!gimme)
1374         Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1375     return gimme;
1376 }
1377
1378
1379 I32
1380 Perl_is_lvalue_sub(pTHX)
1381 {
1382     const I32 cxix = dopoptosub(cxstack_ix);
1383     assert(cxix >= 0);  /* We should only be called from inside subs */
1384
1385     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1386         return CxLVAL(cxstack + cxix);
1387     else
1388         return 0;
1389 }
1390
1391 /* only used by cx_pushsub() */
1392 I32
1393 Perl_was_lvalue_sub(pTHX)
1394 {
1395     const I32 cxix = dopoptosub(cxstack_ix-1);
1396     assert(cxix >= 0);  /* We should only be called from inside subs */
1397
1398     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1399         return CxLVAL(cxstack + cxix);
1400     else
1401         return 0;
1402 }
1403
1404 STATIC I32
1405 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1406 {
1407     I32 i;
1408
1409     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1410 #ifndef DEBUGGING
1411     PERL_UNUSED_CONTEXT;
1412 #endif
1413
1414     for (i = startingblock; i >= 0; i--) {
1415         const PERL_CONTEXT * const cx = &cxstk[i];
1416         switch (CxTYPE(cx)) {
1417         default:
1418             continue;
1419         case CXt_SUB:
1420             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1421              * twice; the first for the normal foo() call, and the second
1422              * for a faked up re-entry into the sub to execute the
1423              * code block. Hide this faked entry from the world. */
1424             if (cx->cx_type & CXp_SUB_RE_FAKE)
1425                 continue;
1426             /* FALLTHROUGH */
1427         case CXt_EVAL:
1428         case CXt_FORMAT:
1429             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1430             return i;
1431         }
1432     }
1433     return i;
1434 }
1435
1436 STATIC I32
1437 S_dopoptoeval(pTHX_ I32 startingblock)
1438 {
1439     I32 i;
1440     for (i = startingblock; i >= 0; i--) {
1441         const PERL_CONTEXT *cx = &cxstack[i];
1442         switch (CxTYPE(cx)) {
1443         default:
1444             continue;
1445         case CXt_EVAL:
1446             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1447             return i;
1448         }
1449     }
1450     return i;
1451 }
1452
1453 STATIC I32
1454 S_dopoptoloop(pTHX_ I32 startingblock)
1455 {
1456     I32 i;
1457     for (i = startingblock; i >= 0; i--) {
1458         const PERL_CONTEXT * const cx = &cxstack[i];
1459         switch (CxTYPE(cx)) {
1460         case CXt_SUBST:
1461         case CXt_SUB:
1462         case CXt_FORMAT:
1463         case CXt_EVAL:
1464         case CXt_NULL:
1465             /* diag_listed_as: Exiting subroutine via %s */
1466             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1467                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1468             if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1469                 return -1;
1470             break;
1471         case CXt_LOOP_PLAIN:
1472         case CXt_LOOP_LAZYIV:
1473         case CXt_LOOP_LAZYSV:
1474         case CXt_LOOP_LIST:
1475         case CXt_LOOP_ARY:
1476             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1477             return i;
1478         }
1479     }
1480     return i;
1481 }
1482
1483 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1484
1485 STATIC I32
1486 S_dopoptogivenfor(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_GIVEN:
1495             DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1496             return i;
1497         case CXt_LOOP_PLAIN:
1498             assert(!(cx->cx_type & CXp_FOR_DEF));
1499             break;
1500         case CXt_LOOP_LAZYIV:
1501         case CXt_LOOP_LAZYSV:
1502         case CXt_LOOP_LIST:
1503         case CXt_LOOP_ARY:
1504             if (cx->cx_type & CXp_FOR_DEF) {
1505                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1506                 return i;
1507             }
1508         }
1509     }
1510     return i;
1511 }
1512
1513 STATIC I32
1514 S_dopoptowhen(pTHX_ I32 startingblock)
1515 {
1516     I32 i;
1517     for (i = startingblock; i >= 0; i--) {
1518         const PERL_CONTEXT *cx = &cxstack[i];
1519         switch (CxTYPE(cx)) {
1520         default:
1521             continue;
1522         case CXt_WHEN:
1523             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1524             return i;
1525         }
1526     }
1527     return i;
1528 }
1529
1530 /* dounwind(): pop all contexts above (but not including) cxix.
1531  * Note that it clears the savestack frame associated with each popped
1532  * context entry, but doesn't free any temps.
1533  * It does a cx_popblock() of the last frame that it pops, and leaves
1534  * cxstack_ix equal to cxix.
1535  */
1536
1537 void
1538 Perl_dounwind(pTHX_ I32 cxix)
1539 {
1540     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1541         return;
1542
1543     while (cxstack_ix > cxix) {
1544         PERL_CONTEXT *cx = CX_CUR();
1545
1546         CX_DEBUG(cx, "UNWIND");
1547         /* Note: we don't need to restore the base context info till the end. */
1548
1549         CX_LEAVE_SCOPE(cx);
1550
1551         switch (CxTYPE(cx)) {
1552         case CXt_SUBST:
1553             CX_POPSUBST(cx);
1554             /* CXt_SUBST is not a block context type, so skip the
1555              * cx_popblock(cx) below */
1556             if (cxstack_ix == cxix + 1) {
1557                 cxstack_ix--;
1558                 return;
1559             }
1560             break;
1561         case CXt_SUB:
1562             cx_popsub(cx);
1563             break;
1564         case CXt_EVAL:
1565             cx_popeval(cx);
1566             break;
1567         case CXt_LOOP_PLAIN:
1568         case CXt_LOOP_LAZYIV:
1569         case CXt_LOOP_LAZYSV:
1570         case CXt_LOOP_LIST:
1571         case CXt_LOOP_ARY:
1572             cx_poploop(cx);
1573             break;
1574         case CXt_WHEN:
1575             cx_popwhen(cx);
1576             break;
1577         case CXt_GIVEN:
1578             cx_popgiven(cx);
1579             break;
1580         case CXt_BLOCK:
1581         case CXt_NULL:
1582             /* these two don't have a POPFOO() */
1583             break;
1584         case CXt_FORMAT:
1585             cx_popformat(cx);
1586             break;
1587         }
1588         if (cxstack_ix == cxix + 1) {
1589             cx_popblock(cx);
1590         }
1591         cxstack_ix--;
1592     }
1593
1594 }
1595
1596 void
1597 Perl_qerror(pTHX_ SV *err)
1598 {
1599     PERL_ARGS_ASSERT_QERROR;
1600
1601     if (PL_in_eval) {
1602         if (PL_in_eval & EVAL_KEEPERR) {
1603                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1604                                                     SVfARG(err));
1605         }
1606         else
1607             sv_catsv(ERRSV, err);
1608     }
1609     else if (PL_errors)
1610         sv_catsv(PL_errors, err);
1611     else
1612         Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1613     if (PL_parser)
1614         ++PL_parser->error_count;
1615 }
1616
1617
1618
1619 /* pop a CXt_EVAL context and in addition, if it was a require then
1620  * based on action:
1621  *     0: do nothing extra;
1622  *     1: undef  $INC{$name}; croak "$name did not return a true value";
1623  *     2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1624  */
1625
1626 static void
1627 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1628 {
1629     SV  *namesv = NULL; /* init to avoid dumb compiler warning */
1630     bool do_croak;
1631
1632     CX_LEAVE_SCOPE(cx);
1633     do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1634     if (do_croak) {
1635         /* keep namesv alive after cx_popeval() */
1636         namesv = cx->blk_eval.old_namesv;
1637         cx->blk_eval.old_namesv = NULL;
1638         sv_2mortal(namesv);
1639     }
1640     cx_popeval(cx);
1641     cx_popblock(cx);
1642     CX_POP(cx);
1643
1644     if (do_croak) {
1645         const char *fmt;
1646         HV *inc_hv = GvHVn(PL_incgv);
1647         I32  klen  = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1648         const char *key = SvPVX_const(namesv);
1649
1650         if (action == 1) {
1651             (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1652             fmt = "%" SVf " did not return a true value";
1653             errsv = namesv;
1654         }
1655         else {
1656             (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1657             fmt = "%" SVf "Compilation failed in require";
1658             if (!errsv)
1659                 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1660         }
1661
1662         Perl_croak(aTHX_ fmt, SVfARG(errsv));
1663     }
1664 }
1665
1666
1667 /* die_unwind(): this is the final destination for the various croak()
1668  * functions. If we're in an eval, unwind the context and other stacks
1669  * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1670  * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1671  * to is a require the exception will be rethrown, as requires don't
1672  * actually trap exceptions.
1673  */
1674
1675 void
1676 Perl_die_unwind(pTHX_ SV *msv)
1677 {
1678     SV *exceptsv = msv;
1679     U8 in_eval = PL_in_eval;
1680     PERL_ARGS_ASSERT_DIE_UNWIND;
1681
1682     if (in_eval) {
1683         I32 cxix;
1684
1685         /* We need to keep this SV alive through all the stack unwinding
1686          * and FREETMPSing below, while ensuing that it doesn't leak
1687          * if we call out to something which then dies (e.g. sub STORE{die}
1688          * when unlocalising a tied var). So we do a dance with
1689          * mortalising and SAVEFREEing.
1690          */
1691         sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1692
1693         /*
1694          * Historically, perl used to set ERRSV ($@) early in the die
1695          * process and rely on it not getting clobbered during unwinding.
1696          * That sucked, because it was liable to get clobbered, so the
1697          * setting of ERRSV used to emit the exception from eval{} has
1698          * been moved to much later, after unwinding (see just before
1699          * JMPENV_JUMP below).  However, some modules were relying on the
1700          * early setting, by examining $@ during unwinding to use it as
1701          * a flag indicating whether the current unwinding was caused by
1702          * an exception.  It was never a reliable flag for that purpose,
1703          * being totally open to false positives even without actual
1704          * clobberage, but was useful enough for production code to
1705          * semantically rely on it.
1706          *
1707          * We'd like to have a proper introspective interface that
1708          * explicitly describes the reason for whatever unwinding
1709          * operations are currently in progress, so that those modules
1710          * work reliably and $@ isn't further overloaded.  But we don't
1711          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1712          * now *additionally* set here, before unwinding, to serve as the
1713          * (unreliable) flag that it used to.
1714          *
1715          * This behaviour is temporary, and should be removed when a
1716          * proper way to detect exceptional unwinding has been developed.
1717          * As of 2010-12, the authors of modules relying on the hack
1718          * are aware of the issue, because the modules failed on
1719          * perls 5.13.{1..7} which had late setting of $@ without this
1720          * early-setting hack.
1721          */
1722         if (!(in_eval & EVAL_KEEPERR))
1723             sv_setsv_flags(ERRSV, exceptsv,
1724                         (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1725
1726         if (in_eval & EVAL_KEEPERR) {
1727             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1728                            SVfARG(exceptsv));
1729         }
1730
1731         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1732                && PL_curstackinfo->si_prev)
1733         {
1734             dounwind(-1);
1735             POPSTACK;
1736         }
1737
1738         if (cxix >= 0) {
1739             PERL_CONTEXT *cx;
1740             SV **oldsp;
1741             U8 gimme;
1742             JMPENV *restartjmpenv;
1743             OP *restartop;
1744
1745             if (cxix < cxstack_ix)
1746                 dounwind(cxix);
1747
1748             cx = CX_CUR();
1749             assert(CxTYPE(cx) == CXt_EVAL);
1750
1751             /* return false to the caller of eval */
1752             oldsp = PL_stack_base + cx->blk_oldsp;
1753             gimme = cx->blk_gimme;
1754             if (gimme == G_SCALAR)
1755                 *++oldsp = &PL_sv_undef;
1756             PL_stack_sp = oldsp;
1757
1758             restartjmpenv = cx->blk_eval.cur_top_env;
1759             restartop     = cx->blk_eval.retop;
1760
1761             /* We need a FREETMPS here to avoid late-called destructors
1762              * clobbering $@ *after* we set it below, e.g.
1763              *    sub DESTROY { eval { die "X" } }
1764              *    eval { my $x = bless []; die $x = 0, "Y" };
1765              *    is($@, "Y")
1766              * Here the clearing of the $x ref mortalises the anon array,
1767              * which needs to be freed *before* $& is set to "Y",
1768              * otherwise it gets overwritten with "X".
1769              *
1770              * However, the FREETMPS will clobber exceptsv, so preserve it
1771              * on the savestack for now.
1772              */
1773             SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1774             FREETMPS;
1775             /* now we're about to pop the savestack, so re-mortalise it */
1776             sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1777
1778             /* Note that unlike pp_entereval, pp_require isn't supposed to
1779              * trap errors. So if we're a require, after we pop the
1780              * CXt_EVAL that pp_require pushed, rethrow the error with
1781              * croak(exceptsv). This is all handled by the call below when
1782              * action == 2.
1783              */
1784             S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1785
1786             if (!(in_eval & EVAL_KEEPERR))
1787                 sv_setsv(ERRSV, exceptsv);
1788             PL_restartjmpenv = restartjmpenv;
1789             PL_restartop = restartop;
1790             JMPENV_JUMP(3);
1791             NOT_REACHED; /* NOTREACHED */
1792         }
1793     }
1794
1795     write_to_stderr(exceptsv);
1796     my_failure_exit();
1797     NOT_REACHED; /* NOTREACHED */
1798 }
1799
1800 PP(pp_xor)
1801 {
1802     dSP; dPOPTOPssrl;
1803     if (SvTRUE_NN(left) != SvTRUE_NN(right))
1804         RETSETYES;
1805     else
1806         RETSETNO;
1807 }
1808
1809 /*
1810
1811 =head1 CV Manipulation Functions
1812
1813 =for apidoc caller_cx
1814
1815 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1816 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1817 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1818 stack frame, so C<caller_cx(0, NULL)> will return information for the
1819 immediately-surrounding Perl code.
1820
1821 This function skips over the automatic calls to C<&DB::sub> made on the
1822 behalf of the debugger.  If the stack frame requested was a sub called by
1823 C<DB::sub>, the return value will be the frame for the call to
1824 C<DB::sub>, since that has the correct line number/etc. for the call
1825 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1826 frame for the sub call itself.
1827
1828 =cut
1829 */
1830
1831 const PERL_CONTEXT *
1832 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1833 {
1834     I32 cxix = dopoptosub(cxstack_ix);
1835     const PERL_CONTEXT *cx;
1836     const PERL_CONTEXT *ccstack = cxstack;
1837     const PERL_SI *top_si = PL_curstackinfo;
1838
1839     for (;;) {
1840         /* we may be in a higher stacklevel, so dig down deeper */
1841         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1842             top_si = top_si->si_prev;
1843             ccstack = top_si->si_cxstack;
1844             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1845         }
1846         if (cxix < 0)
1847             return NULL;
1848         /* caller() should not report the automatic calls to &DB::sub */
1849         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1850                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1851             count++;
1852         if (!count--)
1853             break;
1854         cxix = dopoptosub_at(ccstack, cxix - 1);
1855     }
1856
1857     cx = &ccstack[cxix];
1858     if (dbcxp) *dbcxp = cx;
1859
1860     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1861         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1862         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1863            field below is defined for any cx. */
1864         /* caller() should not report the automatic calls to &DB::sub */
1865         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1866             cx = &ccstack[dbcxix];
1867     }
1868
1869     return cx;
1870 }
1871
1872 PP(pp_caller)
1873 {
1874     dSP;
1875     const PERL_CONTEXT *cx;
1876     const PERL_CONTEXT *dbcx;
1877     U8 gimme = GIMME_V;
1878     const HEK *stash_hek;
1879     I32 count = 0;
1880     bool has_arg = MAXARG && TOPs;
1881     const COP *lcop;
1882
1883     if (MAXARG) {
1884       if (has_arg)
1885         count = POPi;
1886       else (void)POPs;
1887     }
1888
1889     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1890     if (!cx) {
1891         if (gimme != G_ARRAY) {
1892             EXTEND(SP, 1);
1893             RETPUSHUNDEF;
1894         }
1895         RETURN;
1896     }
1897
1898     CX_DEBUG(cx, "CALLER");
1899     assert(CopSTASH(cx->blk_oldcop));
1900     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1901       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1902       : NULL;
1903     if (gimme != G_ARRAY) {
1904         EXTEND(SP, 1);
1905         if (!stash_hek)
1906             PUSHs(&PL_sv_undef);
1907         else {
1908             dTARGET;
1909             sv_sethek(TARG, stash_hek);
1910             PUSHs(TARG);
1911         }
1912         RETURN;
1913     }
1914
1915     EXTEND(SP, 11);
1916
1917     if (!stash_hek)
1918         PUSHs(&PL_sv_undef);
1919     else {
1920         dTARGET;
1921         sv_sethek(TARG, stash_hek);
1922         PUSHTARG;
1923     }
1924     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1925     lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1926                        cx->blk_sub.retop, TRUE);
1927     if (!lcop)
1928         lcop = cx->blk_oldcop;
1929     mPUSHu(CopLINE(lcop));
1930     if (!has_arg)
1931         RETURN;
1932     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1933         /* So is ccstack[dbcxix]. */
1934         if (CvHASGV(dbcx->blk_sub.cv)) {
1935             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1936             PUSHs(boolSV(CxHASARGS(cx)));
1937         }
1938         else {
1939             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1940             PUSHs(boolSV(CxHASARGS(cx)));
1941         }
1942     }
1943     else {
1944         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1945         PUSHs(&PL_sv_zero);
1946     }
1947     gimme = cx->blk_gimme;
1948     if (gimme == G_VOID)
1949         PUSHs(&PL_sv_undef);
1950     else
1951         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1952     if (CxTYPE(cx) == CXt_EVAL) {
1953         /* eval STRING */
1954         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1955             SV *cur_text = cx->blk_eval.cur_text;
1956             if (SvCUR(cur_text) >= 2) {
1957                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1958                                      SvUTF8(cur_text)|SVs_TEMP));
1959             }
1960             else {
1961                 /* I think this is will always be "", but be sure */
1962                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1963             }
1964
1965             PUSHs(&PL_sv_no);
1966         }
1967         /* require */
1968         else if (cx->blk_eval.old_namesv) {
1969             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1970             PUSHs(&PL_sv_yes);
1971         }
1972         /* eval BLOCK (try blocks have old_namesv == 0) */
1973         else {
1974             PUSHs(&PL_sv_undef);
1975             PUSHs(&PL_sv_undef);
1976         }
1977     }
1978     else {
1979         PUSHs(&PL_sv_undef);
1980         PUSHs(&PL_sv_undef);
1981     }
1982     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1983         && CopSTASH_eq(PL_curcop, PL_debstash))
1984     {
1985         /* slot 0 of the pad contains the original @_ */
1986         AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1987                             PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1988                                 cx->blk_sub.olddepth+1]))[0]);
1989         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1990
1991         Perl_init_dbargs(aTHX);
1992
1993         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1994             av_extend(PL_dbargs, AvFILLp(ary) + off);
1995         if (AvFILLp(ary) + 1 + off)
1996             Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1997         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1998     }
1999     mPUSHi(CopHINTS_get(cx->blk_oldcop));
2000     {
2001         SV * mask ;
2002         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2003
2004         if  (old_warnings == pWARN_NONE)
2005             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2006         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2007             mask = &PL_sv_undef ;
2008         else if (old_warnings == pWARN_ALL ||
2009                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2010             /* Get the bit mask for $warnings::Bits{all}, because
2011              * it could have been extended by warnings::register */
2012             SV **bits_all;
2013             HV * const bits = get_hv("warnings::Bits", 0);
2014             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
2015                 mask = newSVsv(*bits_all);
2016             }
2017             else {
2018                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2019             }
2020         }
2021         else
2022             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2023         mPUSHs(mask);
2024     }
2025
2026     PUSHs(cx->blk_oldcop->cop_hints_hash ?
2027           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2028           : &PL_sv_undef);
2029     RETURN;
2030 }
2031
2032 PP(pp_reset)
2033 {
2034     dSP;
2035     const char * tmps;
2036     STRLEN len = 0;
2037     if (MAXARG < 1 || (!TOPs && !POPs)) {
2038         EXTEND(SP, 1);
2039         tmps = NULL, len = 0;
2040     }
2041     else
2042         tmps = SvPVx_const(POPs, len);
2043     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2044     PUSHs(&PL_sv_yes);
2045     RETURN;
2046 }
2047
2048 /* like pp_nextstate, but used instead when the debugger is active */
2049
2050 PP(pp_dbstate)
2051 {
2052     PL_curcop = (COP*)PL_op;
2053     TAINT_NOT;          /* Each statement is presumed innocent */
2054     PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2055     FREETMPS;
2056
2057     PERL_ASYNC_CHECK();
2058
2059     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2060             || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2061     {
2062         dSP;
2063         PERL_CONTEXT *cx;
2064         const U8 gimme = G_ARRAY;
2065         GV * const gv = PL_DBgv;
2066         CV * cv = NULL;
2067
2068         if (gv && isGV_with_GP(gv))
2069             cv = GvCV(gv);
2070
2071         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2072             DIE(aTHX_ "No DB::DB routine defined");
2073
2074         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2075             /* don't do recursive DB::DB call */
2076             return NORMAL;
2077
2078         if (CvISXSUB(cv)) {
2079             ENTER;
2080             SAVEI32(PL_debug);
2081             PL_debug = 0;
2082             SAVESTACK_POS();
2083             SAVETMPS;
2084             PUSHMARK(SP);
2085             (void)(*CvXSUB(cv))(aTHX_ cv);
2086             FREETMPS;
2087             LEAVE;
2088             return NORMAL;
2089         }
2090         else {
2091             cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2092             cx_pushsub(cx, cv, PL_op->op_next, 0);
2093             /* OP_DBSTATE's op_private holds hint bits rather than
2094              * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2095              * any CxLVAL() flags that have now been mis-calculated */
2096             cx->blk_u16 = 0;
2097
2098             SAVEI32(PL_debug);
2099             PL_debug = 0;
2100             SAVESTACK_POS();
2101             CvDEPTH(cv)++;
2102             if (CvDEPTH(cv) >= 2)
2103                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2104             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2105             RETURNOP(CvSTART(cv));
2106         }
2107     }
2108     else
2109         return NORMAL;
2110 }
2111
2112
2113 PP(pp_enter)
2114 {
2115     U8 gimme = GIMME_V;
2116
2117     (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2118     return NORMAL;
2119 }
2120
2121
2122 PP(pp_leave)
2123 {
2124     PERL_CONTEXT *cx;
2125     SV **oldsp;
2126     U8 gimme;
2127
2128     cx = CX_CUR();
2129     assert(CxTYPE(cx) == CXt_BLOCK);
2130
2131     if (PL_op->op_flags & OPf_SPECIAL)
2132         /* fake block should preserve $1 et al; e.g.  /(...)/ while ...; */
2133         cx->blk_oldpm = PL_curpm;
2134
2135     oldsp = PL_stack_base + cx->blk_oldsp;
2136     gimme = cx->blk_gimme;
2137
2138     if (gimme == G_VOID)
2139         PL_stack_sp = oldsp;
2140     else
2141         leave_adjust_stacks(oldsp, oldsp, gimme,
2142                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2143
2144     CX_LEAVE_SCOPE(cx);
2145     cx_popblock(cx);
2146     CX_POP(cx);
2147
2148     return NORMAL;
2149 }
2150
2151 static bool
2152 S_outside_integer(pTHX_ SV *sv)
2153 {
2154   if (SvOK(sv)) {
2155     const NV nv = SvNV_nomg(sv);
2156     if (Perl_isinfnan(nv))
2157       return TRUE;
2158 #ifdef NV_PRESERVES_UV
2159     if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2160       return TRUE;
2161 #else
2162     if (nv <= (NV)IV_MIN)
2163       return TRUE;
2164     if ((nv > 0) &&
2165         ((nv > (NV)UV_MAX ||
2166           SvUV_nomg(sv) > (UV)IV_MAX)))
2167       return TRUE;
2168 #endif
2169   }
2170   return FALSE;
2171 }
2172
2173 PP(pp_enteriter)
2174 {
2175     dSP; dMARK;
2176     PERL_CONTEXT *cx;
2177     const U8 gimme = GIMME_V;
2178     void *itervarp; /* GV or pad slot of the iteration variable */
2179     SV   *itersave; /* the old var in the iterator var slot */
2180     U8 cxflags = 0;
2181
2182     if (PL_op->op_targ) {                        /* "my" variable */
2183         itervarp = &PAD_SVl(PL_op->op_targ);
2184         itersave = *(SV**)itervarp;
2185         assert(itersave);
2186         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2187             /* the SV currently in the pad slot is never live during
2188              * iteration (the slot is always aliased to one of the items)
2189              * so it's always stale */
2190             SvPADSTALE_on(itersave);
2191         }
2192         SvREFCNT_inc_simple_void_NN(itersave);
2193         cxflags = CXp_FOR_PAD;
2194     }
2195     else {
2196         SV * const sv = POPs;
2197         itervarp = (void *)sv;
2198         if (LIKELY(isGV(sv))) {         /* symbol table variable */
2199             itersave = GvSV(sv);
2200             SvREFCNT_inc_simple_void(itersave);
2201             cxflags = CXp_FOR_GV;
2202             if (PL_op->op_private & OPpITER_DEF)
2203                 cxflags |= CXp_FOR_DEF;
2204         }
2205         else {                          /* LV ref: for \$foo (...) */
2206             assert(SvTYPE(sv) == SVt_PVMG);
2207             assert(SvMAGIC(sv));
2208             assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2209             itersave = NULL;
2210             cxflags = CXp_FOR_LVREF;
2211         }
2212     }
2213     /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2214     assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2215
2216     /* Note that this context is initially set as CXt_NULL. Further on
2217      * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2218      * there mustn't be anything in the blk_loop substruct that requires
2219      * freeing or undoing, in case we die in the meantime. And vice-versa.
2220      */
2221     cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2222     cx_pushloop_for(cx, itervarp, itersave);
2223
2224     if (PL_op->op_flags & OPf_STACKED) {
2225         /* OPf_STACKED implies either a single array: for(@), with a
2226          * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2227          * the stack */
2228         SV *maybe_ary = POPs;
2229         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2230             /* range */
2231             dPOPss;
2232             SV * const right = maybe_ary;
2233             if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2234                 DIE(aTHX_ "Assigned value is not a reference");
2235             SvGETMAGIC(sv);
2236             SvGETMAGIC(right);
2237             if (RANGE_IS_NUMERIC(sv,right)) {
2238                 cx->cx_type |= CXt_LOOP_LAZYIV;
2239                 if (S_outside_integer(aTHX_ sv) ||
2240                     S_outside_integer(aTHX_ right))
2241                     DIE(aTHX_ "Range iterator outside integer range");
2242                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2243                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2244             }
2245             else {
2246                 cx->cx_type |= CXt_LOOP_LAZYSV;
2247                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2248                 cx->blk_loop.state_u.lazysv.end = right;
2249                 SvREFCNT_inc_simple_void_NN(right);
2250                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2251                 /* This will do the upgrade to SVt_PV, and warn if the value
2252                    is uninitialised.  */
2253                 (void) SvPV_nolen_const(right);
2254                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2255                    to replace !SvOK() with a pointer to "".  */
2256                 if (!SvOK(right)) {
2257                     SvREFCNT_dec(right);
2258                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2259                 }
2260             }
2261         }
2262         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2263             /* for (@array) {} */
2264             cx->cx_type |= CXt_LOOP_ARY;
2265             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2266             SvREFCNT_inc_simple_void_NN(maybe_ary);
2267             cx->blk_loop.state_u.ary.ix =
2268                 (PL_op->op_private & OPpITER_REVERSED) ?
2269                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2270                 -1;
2271         }
2272         /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2273     }
2274     else { /* iterating over items on the stack */
2275         cx->cx_type |= CXt_LOOP_LIST;
2276         cx->blk_oldsp = SP - PL_stack_base;
2277         cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2278         cx->blk_loop.state_u.stack.ix =
2279             (PL_op->op_private & OPpITER_REVERSED)
2280                 ? cx->blk_oldsp + 1
2281                 : cx->blk_loop.state_u.stack.basesp;
2282         /* pre-extend stack so pp_iter doesn't have to check every time
2283          * it pushes yes/no */
2284         EXTEND(SP, 1);
2285     }
2286
2287     RETURN;
2288 }
2289
2290 PP(pp_enterloop)
2291 {
2292     PERL_CONTEXT *cx;
2293     const U8 gimme = GIMME_V;
2294
2295     cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2296     cx_pushloop_plain(cx);
2297     return NORMAL;
2298 }
2299
2300
2301 PP(pp_leaveloop)
2302 {
2303     PERL_CONTEXT *cx;
2304     U8 gimme;
2305     SV **base;
2306     SV **oldsp;
2307
2308     cx = CX_CUR();
2309     assert(CxTYPE_is_LOOP(cx));
2310     oldsp = PL_stack_base + cx->blk_oldsp;
2311     base = CxTYPE(cx) == CXt_LOOP_LIST
2312                 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2313                 : oldsp;
2314     gimme = cx->blk_gimme;
2315
2316     if (gimme == G_VOID)
2317         PL_stack_sp = base;
2318     else
2319         leave_adjust_stacks(oldsp, base, gimme,
2320                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2321
2322     CX_LEAVE_SCOPE(cx);
2323     cx_poploop(cx);     /* Stack values are safe: release loop vars ... */
2324     cx_popblock(cx);
2325     CX_POP(cx);
2326
2327     return NORMAL;
2328 }
2329
2330
2331 /* This duplicates most of pp_leavesub, but with additional code to handle
2332  * return args in lvalue context. It was forked from pp_leavesub to
2333  * avoid slowing down that function any further.
2334  *
2335  * Any changes made to this function may need to be copied to pp_leavesub
2336  * and vice-versa.
2337  *
2338  * also tail-called by pp_return
2339  */
2340
2341 PP(pp_leavesublv)
2342 {
2343     U8 gimme;
2344     PERL_CONTEXT *cx;
2345     SV **oldsp;
2346     OP *retop;
2347
2348     cx = CX_CUR();
2349     assert(CxTYPE(cx) == CXt_SUB);
2350
2351     if (CxMULTICALL(cx)) {
2352         /* entry zero of a stack is always PL_sv_undef, which
2353          * simplifies converting a '()' return into undef in scalar context */
2354         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2355         return 0;
2356     }
2357
2358     gimme = cx->blk_gimme;
2359     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2360
2361     if (gimme == G_VOID)
2362         PL_stack_sp = oldsp;
2363     else {
2364         U8   lval    = CxLVAL(cx);
2365         bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2366         const char *what = NULL;
2367
2368         if (gimme == G_SCALAR) {
2369             if (is_lval) {
2370                 /* check for bad return arg */
2371                 if (oldsp < PL_stack_sp) {
2372                     SV *sv = *PL_stack_sp;
2373                     if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2374                         what =
2375                             SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2376                             : "a readonly value" : "a temporary";
2377                     }
2378                     else goto ok;
2379                 }
2380                 else {
2381                     /* sub:lvalue{} will take us here. */
2382                     what = "undef";
2383                 }
2384               croak:
2385                 Perl_croak(aTHX_
2386                           "Can't return %s from lvalue subroutine", what);
2387             }
2388
2389           ok:
2390             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2391
2392             if (lval & OPpDEREF) {
2393                 /* lval_sub()->{...} and similar */
2394                 dSP;
2395                 SvGETMAGIC(TOPs);
2396                 if (!SvOK(TOPs)) {
2397                     TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2398                 }
2399                 PUTBACK;
2400             }
2401         }
2402         else {
2403             assert(gimme == G_ARRAY);
2404             assert (!(lval & OPpDEREF));
2405
2406             if (is_lval) {
2407                 /* scan for bad return args */
2408                 SV **p;
2409                 for (p = PL_stack_sp; p > oldsp; p--) {
2410                     SV *sv = *p;
2411                     /* the PL_sv_undef exception is to allow things like
2412                      * this to work, where PL_sv_undef acts as 'skip'
2413                      * placeholder on the LHS of list assigns:
2414                      *    sub foo :lvalue { undef }
2415                      *    ($a, undef, foo(), $b) = 1..4;
2416                      */
2417                     if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2418                     {
2419                         /* Might be flattened array after $#array =  */
2420                         what = SvREADONLY(sv)
2421                                 ? "a readonly value" : "a temporary";
2422                         goto croak;
2423                     }
2424                 }
2425             }
2426
2427             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2428         }
2429     }
2430
2431     CX_LEAVE_SCOPE(cx);
2432     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
2433     cx_popblock(cx);
2434     retop =  cx->blk_sub.retop;
2435     CX_POP(cx);
2436
2437     return retop;
2438 }
2439
2440
2441 PP(pp_return)
2442 {
2443     dSP; dMARK;
2444     PERL_CONTEXT *cx;
2445     const I32 cxix = dopoptosub(cxstack_ix);
2446
2447     assert(cxstack_ix >= 0);
2448     if (cxix < cxstack_ix) {
2449         if (cxix < 0) {
2450             if (!(       PL_curstackinfo->si_type == PERLSI_SORT
2451                   || (   PL_curstackinfo->si_type == PERLSI_MULTICALL
2452                       && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2453                  )
2454             )
2455                 DIE(aTHX_ "Can't return outside a subroutine");
2456             /* We must be in:
2457              *  a sort block, which is a CXt_NULL not a CXt_SUB;
2458              *  or a /(?{...})/ block.
2459              * Handle specially. */
2460             assert(CxTYPE(&cxstack[0]) == CXt_NULL
2461                     || (   CxTYPE(&cxstack[0]) == CXt_SUB
2462                         && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2463             if (cxstack_ix > 0) {
2464                 /* See comment below about context popping. Since we know
2465                  * we're scalar and not lvalue, we can preserve the return
2466                  * value in a simpler fashion than there. */
2467                 SV *sv = *SP;
2468                 assert(cxstack[0].blk_gimme == G_SCALAR);
2469                 if (   (sp != PL_stack_base)
2470                     && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2471                 )
2472                     *SP = sv_mortalcopy(sv);
2473                 dounwind(0);
2474             }
2475             /* caller responsible for popping cxstack[0] */
2476             return 0;
2477         }
2478
2479         /* There are contexts that need popping. Doing this may free the
2480          * return value(s), so preserve them first: e.g. popping the plain
2481          * loop here would free $x:
2482          *     sub f {  { my $x = 1; return $x } }
2483          * We may also need to shift the args down; for example,
2484          *    for (1,2) { return 3,4 }
2485          * leaves 1,2,3,4 on the stack. Both these actions will be done by
2486          * leave_adjust_stacks(), along with freeing any temps. Note that
2487          * whoever we tail-call (e.g. pp_leaveeval) will also call
2488          * leave_adjust_stacks(); however, the second call is likely to
2489          * just see a bunch of SvTEMPs with a ref count of 1, and so just
2490          * pass them through, rather than copying them again. So this
2491          * isn't as inefficient as it sounds.
2492          */
2493         cx = &cxstack[cxix];
2494         PUTBACK;
2495         if (cx->blk_gimme != G_VOID)
2496             leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2497                     cx->blk_gimme,
2498                     CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2499                         ? 3 : 0);
2500         SPAGAIN;
2501         dounwind(cxix);
2502         cx = &cxstack[cxix]; /* CX stack may have been realloced */
2503     }
2504     else {
2505         /* Like in the branch above, we need to handle any extra junk on
2506          * the stack. But because we're not also popping extra contexts, we
2507          * don't have to worry about prematurely freeing args. So we just
2508          * need to do the bare minimum to handle junk, and leave the main
2509          * arg processing in the function we tail call, e.g. pp_leavesub.
2510          * In list context we have to splice out the junk; in scalar
2511          * context we can leave as-is (pp_leavesub will later return the
2512          * top stack element). But for an  empty arg list, e.g.
2513          *    for (1,2) { return }
2514          * we need to set sp = oldsp so that pp_leavesub knows to push
2515          * &PL_sv_undef onto the stack.
2516          */
2517         SV **oldsp;
2518         cx = &cxstack[cxix];
2519         oldsp = PL_stack_base + cx->blk_oldsp;
2520         if (oldsp != MARK) {
2521             SSize_t nargs = SP - MARK;
2522             if (nargs) {
2523                 if (cx->blk_gimme == G_ARRAY) {
2524                     /* shift return args to base of call stack frame */
2525                     Move(MARK + 1, oldsp + 1, nargs, SV*);
2526                     PL_stack_sp  = oldsp + nargs;
2527                 }
2528             }
2529             else
2530                 PL_stack_sp  = oldsp;
2531         }
2532     }
2533
2534     /* fall through to a normal exit */
2535     switch (CxTYPE(cx)) {
2536     case CXt_EVAL:
2537         return CxTRYBLOCK(cx)
2538             ? Perl_pp_leavetry(aTHX)
2539             : Perl_pp_leaveeval(aTHX);
2540     case CXt_SUB:
2541         return CvLVALUE(cx->blk_sub.cv)
2542             ? Perl_pp_leavesublv(aTHX)
2543             : Perl_pp_leavesub(aTHX);
2544     case CXt_FORMAT:
2545         return Perl_pp_leavewrite(aTHX);
2546     default:
2547         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2548     }
2549 }
2550
2551 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2552
2553 static PERL_CONTEXT *
2554 S_unwind_loop(pTHX)
2555 {
2556     I32 cxix;
2557     if (PL_op->op_flags & OPf_SPECIAL) {
2558         cxix = dopoptoloop(cxstack_ix);
2559         if (cxix < 0)
2560             /* diag_listed_as: Can't "last" outside a loop block */
2561             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2562                 OP_NAME(PL_op));
2563     }
2564     else {
2565         dSP;
2566         STRLEN label_len;
2567         const char * const label =
2568             PL_op->op_flags & OPf_STACKED
2569                 ? SvPV(TOPs,label_len)
2570                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2571         const U32 label_flags =
2572             PL_op->op_flags & OPf_STACKED
2573                 ? SvUTF8(POPs)
2574                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2575         PUTBACK;
2576         cxix = dopoptolabel(label, label_len, label_flags);
2577         if (cxix < 0)
2578             /* diag_listed_as: Label not found for "last %s" */
2579             Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2580                                        OP_NAME(PL_op),
2581                                        SVfARG(PL_op->op_flags & OPf_STACKED
2582                                               && !SvGMAGICAL(TOPp1s)
2583                                               ? TOPp1s
2584                                               : newSVpvn_flags(label,
2585                                                     label_len,
2586                                                     label_flags | SVs_TEMP)));
2587     }
2588     if (cxix < cxstack_ix)
2589         dounwind(cxix);
2590     return &cxstack[cxix];
2591 }
2592
2593
2594 PP(pp_last)
2595 {
2596     PERL_CONTEXT *cx;
2597     OP* nextop;
2598
2599     cx = S_unwind_loop(aTHX);
2600
2601     assert(CxTYPE_is_LOOP(cx));
2602     PL_stack_sp = PL_stack_base
2603                 + (CxTYPE(cx) == CXt_LOOP_LIST
2604                     ?  cx->blk_loop.state_u.stack.basesp
2605                     : cx->blk_oldsp
2606                 );
2607
2608     TAINT_NOT;
2609
2610     /* Stack values are safe: */
2611     CX_LEAVE_SCOPE(cx);
2612     cx_poploop(cx);     /* release loop vars ... */
2613     cx_popblock(cx);
2614     nextop = cx->blk_loop.my_op->op_lastop->op_next;
2615     CX_POP(cx);
2616
2617     return nextop;
2618 }
2619
2620 PP(pp_next)
2621 {
2622     PERL_CONTEXT *cx;
2623
2624     /* if not a bare 'next' in the main scope, search for it */
2625     cx = CX_CUR();
2626     if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2627         cx = S_unwind_loop(aTHX);
2628
2629     cx_topblock(cx);
2630     PL_curcop = cx->blk_oldcop;
2631     PERL_ASYNC_CHECK();
2632     return (cx)->blk_loop.my_op->op_nextop;
2633 }
2634
2635 PP(pp_redo)
2636 {
2637     PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2638     OP* redo_op = cx->blk_loop.my_op->op_redoop;
2639
2640     if (redo_op->op_type == OP_ENTER) {
2641         /* pop one less context to avoid $x being freed in while (my $x..) */
2642         cxstack_ix++;
2643         cx = CX_CUR();
2644         assert(CxTYPE(cx) == CXt_BLOCK);
2645         redo_op = redo_op->op_next;
2646     }
2647
2648     FREETMPS;
2649     CX_LEAVE_SCOPE(cx);
2650     cx_topblock(cx);
2651     PL_curcop = cx->blk_oldcop;
2652     PERL_ASYNC_CHECK();
2653     return redo_op;
2654 }
2655
2656 STATIC OP *
2657 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2658 {
2659     OP **ops = opstack;
2660     static const char* const too_deep = "Target of goto is too deeply nested";
2661
2662     PERL_ARGS_ASSERT_DOFINDLABEL;
2663
2664     if (ops >= oplimit)
2665         Perl_croak(aTHX_ "%s", too_deep);
2666     if (o->op_type == OP_LEAVE ||
2667         o->op_type == OP_SCOPE ||
2668         o->op_type == OP_LEAVELOOP ||
2669         o->op_type == OP_LEAVESUB ||
2670         o->op_type == OP_LEAVETRY)
2671     {
2672         *ops++ = cUNOPo->op_first;
2673         if (ops >= oplimit)
2674             Perl_croak(aTHX_ "%s", too_deep);
2675     }
2676     *ops = 0;
2677     if (o->op_flags & OPf_KIDS) {
2678         OP *kid;
2679         /* First try all the kids at this level, since that's likeliest. */
2680         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2681             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2682                 STRLEN kid_label_len;
2683                 U32 kid_label_flags;
2684                 const char *kid_label = CopLABEL_len_flags(kCOP,
2685                                                     &kid_label_len, &kid_label_flags);
2686                 if (kid_label && (
2687                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2688                         (flags & SVf_UTF8)
2689                             ? (bytes_cmp_utf8(
2690                                         (const U8*)kid_label, kid_label_len,
2691                                         (const U8*)label, len) == 0)
2692                             : (bytes_cmp_utf8(
2693                                         (const U8*)label, len,
2694                                         (const U8*)kid_label, kid_label_len) == 0)
2695                     : ( len == kid_label_len && ((kid_label == label)
2696                                     || memEQ(kid_label, label, len)))))
2697                     return kid;
2698             }
2699         }
2700         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2701             if (kid == PL_lastgotoprobe)
2702                 continue;
2703             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2704                 if (ops == opstack)
2705                     *ops++ = kid;
2706                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2707                          ops[-1]->op_type == OP_DBSTATE)
2708                     ops[-1] = kid;
2709                 else
2710                     *ops++ = kid;
2711             }
2712             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2713                 return o;
2714         }
2715     }
2716     *ops = 0;
2717     return 0;
2718 }
2719
2720
2721 /* also used for: pp_dump() */
2722
2723 PP(pp_goto)
2724 {
2725     dVAR; dSP;
2726     OP *retop = NULL;
2727     I32 ix;
2728     PERL_CONTEXT *cx;
2729 #define GOTO_DEPTH 64
2730     OP *enterops[GOTO_DEPTH];
2731     const char *label = NULL;
2732     STRLEN label_len = 0;
2733     U32 label_flags = 0;
2734     const bool do_dump = (PL_op->op_type == OP_DUMP);
2735     static const char* const must_have_label = "goto must have label";
2736
2737     if (PL_op->op_flags & OPf_STACKED) {
2738         /* goto EXPR  or  goto &foo */
2739
2740         SV * const sv = POPs;
2741         SvGETMAGIC(sv);
2742
2743         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2744             /* This egregious kludge implements goto &subroutine */
2745             I32 cxix;
2746             PERL_CONTEXT *cx;
2747             CV *cv = MUTABLE_CV(SvRV(sv));
2748             AV *arg = GvAV(PL_defgv);
2749
2750             while (!CvROOT(cv) && !CvXSUB(cv)) {
2751                 const GV * const gv = CvGV(cv);
2752                 if (gv) {
2753                     GV *autogv;
2754                     SV *tmpstr;
2755                     /* autoloaded stub? */
2756                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2757                         continue;
2758                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2759                                           GvNAMELEN(gv),
2760                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2761                     if (autogv && (cv = GvCV(autogv)))
2762                         continue;
2763                     tmpstr = sv_newmortal();
2764                     gv_efullname3(tmpstr, gv, NULL);
2765                     DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2766                 }
2767                 DIE(aTHX_ "Goto undefined subroutine");
2768             }
2769
2770             cxix = dopoptosub(cxstack_ix);
2771             if (cxix < 0) {
2772                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2773             }
2774             cx  = &cxstack[cxix];
2775             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2776             if (CxTYPE(cx) == CXt_EVAL) {
2777                 if (CxREALEVAL(cx))
2778                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2779                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2780                 else
2781                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2782                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2783             }
2784             else if (CxMULTICALL(cx))
2785                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2786
2787             /* First do some returnish stuff. */
2788
2789             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2790             FREETMPS;
2791             if (cxix < cxstack_ix) {
2792                 dounwind(cxix);
2793             }
2794             cx = CX_CUR();
2795             cx_topblock(cx);
2796             SPAGAIN;
2797
2798             /* protect @_ during save stack unwind. */
2799             if (arg)
2800                 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2801
2802             assert(PL_scopestack_ix == cx->blk_oldscopesp);
2803             CX_LEAVE_SCOPE(cx);
2804
2805             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2806                 /* this is part of cx_popsub_args() */
2807                 AV* av = MUTABLE_AV(PAD_SVl(0));
2808                 assert(AvARRAY(MUTABLE_AV(
2809                     PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2810                             CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2811
2812                 /* we are going to donate the current @_ from the old sub
2813                  * to the new sub. This first part of the donation puts a
2814                  * new empty AV in the pad[0] slot of the old sub,
2815                  * unless pad[0] and @_ differ (e.g. if the old sub did
2816                  * local *_ = []); in which case clear the old pad[0]
2817                  * array in the usual way */
2818                 if (av == arg || AvREAL(av))
2819                     clear_defarray(av, av == arg);
2820                 else CLEAR_ARGARRAY(av);
2821             }
2822
2823             /* don't restore PL_comppad here. It won't be needed if the
2824              * sub we're going to is non-XS, but restoring it early then
2825              * croaking (e.g. the "Goto undefined subroutine" below)
2826              * means the CX block gets processed again in dounwind,
2827              * but this time with the wrong PL_comppad */
2828
2829             /* A destructor called during LEAVE_SCOPE could have undefined
2830              * our precious cv.  See bug #99850. */
2831             if (!CvROOT(cv) && !CvXSUB(cv)) {
2832                 const GV * const gv = CvGV(cv);
2833                 if (gv) {
2834                     SV * const tmpstr = sv_newmortal();
2835                     gv_efullname3(tmpstr, gv, NULL);
2836                     DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2837                                SVfARG(tmpstr));
2838                 }
2839                 DIE(aTHX_ "Goto undefined subroutine");
2840             }
2841
2842             if (CxTYPE(cx) == CXt_SUB) {
2843                 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2844                 SvREFCNT_dec_NN(cx->blk_sub.cv);
2845             }
2846
2847             /* Now do some callish stuff. */
2848             if (CvISXSUB(cv)) {
2849                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2850                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2851                 SV** mark;
2852
2853                 ENTER;
2854                 SAVETMPS;
2855                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2856
2857                 /* put GvAV(defgv) back onto stack */
2858                 if (items) {
2859                     EXTEND(SP, items+1); /* @_ could have been extended. */
2860                 }
2861                 mark = SP;
2862                 if (items) {
2863                     SSize_t index;
2864                     bool r = cBOOL(AvREAL(arg));
2865                     for (index=0; index<items; index++)
2866                     {
2867                         SV *sv;
2868                         if (m) {
2869                             SV ** const svp = av_fetch(arg, index, 0);
2870                             sv = svp ? *svp : NULL;
2871                         }
2872                         else sv = AvARRAY(arg)[index];
2873                         SP[index+1] = sv
2874                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2875                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2876                     }
2877                 }
2878                 SP += items;
2879                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2880                     /* Restore old @_ */
2881                     CX_POP_SAVEARRAY(cx);
2882                 }
2883
2884                 retop = cx->blk_sub.retop;
2885                 PL_comppad = cx->blk_sub.prevcomppad;
2886                 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2887
2888                 /* XS subs don't have a CXt_SUB, so pop it;
2889                  * this is a cx_popblock(), less all the stuff we already did
2890                  * for cx_topblock() earlier */
2891                 PL_curcop = cx->blk_oldcop;
2892                 CX_POP(cx);
2893
2894                 /* Push a mark for the start of arglist */
2895                 PUSHMARK(mark);
2896                 PUTBACK;
2897                 (void)(*CvXSUB(cv))(aTHX_ cv);
2898                 LEAVE;
2899                 goto _return;
2900             }
2901             else {
2902                 PADLIST * const padlist = CvPADLIST(cv);
2903
2904                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2905
2906                 /* partial unrolled cx_pushsub(): */
2907
2908                 cx->blk_sub.cv = cv;
2909                 cx->blk_sub.olddepth = CvDEPTH(cv);
2910
2911                 CvDEPTH(cv)++;
2912                 SvREFCNT_inc_simple_void_NN(cv);
2913                 if (CvDEPTH(cv) > 1) {
2914                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2915                         sub_crush_depth(cv);
2916                     pad_push(padlist, CvDEPTH(cv));
2917                 }
2918                 PL_curcop = cx->blk_oldcop;
2919                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2920                 if (CxHASARGS(cx))
2921                 {
2922                     /* second half of donating @_ from the old sub to the
2923                      * new sub: abandon the original pad[0] AV in the
2924                      * new sub, and replace it with the donated @_.
2925                      * pad[0] takes ownership of the extra refcount
2926                      * we gave arg earlier */
2927                     if (arg) {
2928                         SvREFCNT_dec(PAD_SVl(0));
2929                         PAD_SVl(0) = (SV *)arg;
2930                         SvREFCNT_inc_simple_void_NN(arg);
2931                     }
2932
2933                     /* GvAV(PL_defgv) might have been modified on scope
2934                        exit, so point it at arg again. */
2935                     if (arg != GvAV(PL_defgv)) {
2936                         AV * const av = GvAV(PL_defgv);
2937                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2938                         SvREFCNT_dec(av);
2939                     }
2940                 }
2941
2942                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2943                     Perl_get_db_sub(aTHX_ NULL, cv);
2944                     if (PERLDB_GOTO) {
2945                         CV * const gotocv = get_cvs("DB::goto", 0);
2946                         if (gotocv) {
2947                             PUSHMARK( PL_stack_sp );
2948                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2949                             PL_stack_sp--;
2950                         }
2951                     }
2952                 }
2953                 retop = CvSTART(cv);
2954                 goto putback_return;
2955             }
2956         }
2957         else {
2958             /* goto EXPR */
2959             label       = SvPV_nomg_const(sv, label_len);
2960             label_flags = SvUTF8(sv);
2961         }
2962     }
2963     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2964         /* goto LABEL  or  dump LABEL */
2965         label       = cPVOP->op_pv;
2966         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2967         label_len   = strlen(label);
2968     }
2969     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2970
2971     PERL_ASYNC_CHECK();
2972
2973     if (label_len) {
2974         OP *gotoprobe = NULL;
2975         bool leaving_eval = FALSE;
2976         bool in_block = FALSE;
2977         bool pseudo_block = FALSE;
2978         PERL_CONTEXT *last_eval_cx = NULL;
2979
2980         /* find label */
2981
2982         PL_lastgotoprobe = NULL;
2983         *enterops = 0;
2984         for (ix = cxstack_ix; ix >= 0; ix--) {
2985             cx = &cxstack[ix];
2986             switch (CxTYPE(cx)) {
2987             case CXt_EVAL:
2988                 leaving_eval = TRUE;
2989                 if (!CxTRYBLOCK(cx)) {
2990                     gotoprobe = (last_eval_cx ?
2991                                 last_eval_cx->blk_eval.old_eval_root :
2992                                 PL_eval_root);
2993                     last_eval_cx = cx;
2994                     break;
2995                 }
2996                 /* else fall through */
2997             case CXt_LOOP_PLAIN:
2998             case CXt_LOOP_LAZYIV:
2999             case CXt_LOOP_LAZYSV:
3000             case CXt_LOOP_LIST:
3001             case CXt_LOOP_ARY:
3002             case CXt_GIVEN:
3003             case CXt_WHEN:
3004                 gotoprobe = OpSIBLING(cx->blk_oldcop);
3005                 break;
3006             case CXt_SUBST:
3007                 continue;
3008             case CXt_BLOCK:
3009                 if (ix) {
3010                     gotoprobe = OpSIBLING(cx->blk_oldcop);
3011                     in_block = TRUE;
3012                 } else
3013                     gotoprobe = PL_main_root;
3014                 break;
3015             case CXt_SUB:
3016                 gotoprobe = CvROOT(cx->blk_sub.cv);
3017                 pseudo_block = cBOOL(CxMULTICALL(cx));
3018                 break;
3019             case CXt_FORMAT:
3020             case CXt_NULL:
3021                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3022             default:
3023                 if (ix)
3024                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3025                         CxTYPE(cx), (long) ix);
3026                 gotoprobe = PL_main_root;
3027                 break;
3028             }
3029             if (gotoprobe) {
3030                 OP *sibl1, *sibl2;
3031
3032                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3033                                     enterops, enterops + GOTO_DEPTH);
3034                 if (retop)
3035                     break;
3036                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3037                      sibl1->op_type == OP_UNSTACK &&
3038                      (sibl2 = OpSIBLING(sibl1)))
3039                 {
3040                     retop = dofindlabel(sibl2,
3041                                         label, label_len, label_flags, enterops,
3042                                         enterops + GOTO_DEPTH);
3043                     if (retop)
3044                         break;
3045                 }
3046             }
3047             if (pseudo_block)
3048                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3049             PL_lastgotoprobe = gotoprobe;
3050         }
3051         if (!retop)
3052             DIE(aTHX_ "Can't find label %" UTF8f,
3053                        UTF8fARG(label_flags, label_len, label));
3054
3055         /* if we're leaving an eval, check before we pop any frames
3056            that we're not going to punt, otherwise the error
3057            won't be caught */
3058
3059         if (leaving_eval && *enterops && enterops[1]) {
3060             I32 i;
3061             for (i = 1; enterops[i]; i++)
3062                 if (enterops[i]->op_type == OP_ENTERITER)
3063                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3064         }
3065
3066         if (*enterops && enterops[1]) {
3067             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3068             if (enterops[i])
3069                 deprecate("\"goto\" to jump into a construct");
3070         }
3071
3072         /* pop unwanted frames */
3073
3074         if (ix < cxstack_ix) {
3075             if (ix < 0)
3076                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3077             dounwind(ix);
3078             cx = CX_CUR();
3079             cx_topblock(cx);
3080         }
3081
3082         /* push wanted frames */
3083
3084         if (*enterops && enterops[1]) {
3085             OP * const oldop = PL_op;
3086             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3087             for (; enterops[ix]; ix++) {
3088                 PL_op = enterops[ix];
3089                 /* Eventually we may want to stack the needed arguments
3090                  * for each op.  For now, we punt on the hard ones. */
3091                 if (PL_op->op_type == OP_ENTERITER)
3092                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3093                 PL_op->op_ppaddr(aTHX);
3094             }
3095             PL_op = oldop;
3096         }
3097     }
3098
3099     if (do_dump) {
3100 #ifdef VMS
3101         if (!retop) retop = PL_main_start;
3102 #endif
3103         PL_restartop = retop;
3104         PL_do_undump = TRUE;
3105
3106         my_unexec();
3107
3108         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3109         PL_do_undump = FALSE;
3110     }
3111
3112     putback_return:
3113     PL_stack_sp = sp;
3114     _return:
3115     PERL_ASYNC_CHECK();
3116     return retop;
3117 }
3118
3119 PP(pp_exit)
3120 {
3121     dSP;
3122     I32 anum;
3123
3124     if (MAXARG < 1)
3125         anum = 0;
3126     else if (!TOPs) {
3127         anum = 0; (void)POPs;
3128     }
3129     else {
3130         anum = SvIVx(POPs);
3131 #ifdef VMS
3132         if (anum == 1
3133          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3134             anum = 0;
3135         VMSISH_HUSHED  =
3136             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3137 #endif
3138     }
3139     PL_exit_flags |= PERL_EXIT_EXPECTED;
3140     my_exit(anum);
3141     PUSHs(&PL_sv_undef);
3142     RETURN;
3143 }
3144
3145 /* Eval. */
3146
3147 STATIC void
3148 S_save_lines(pTHX_ AV *array, SV *sv)
3149 {
3150     const char *s = SvPVX_const(sv);
3151     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3152     I32 line = 1;
3153
3154     PERL_ARGS_ASSERT_SAVE_LINES;
3155
3156     while (s && s < send) {
3157         const char *t;
3158         SV * const tmpstr = newSV_type(SVt_PVMG);
3159
3160         t = (const char *)memchr(s, '\n', send - s);
3161         if (t)
3162             t++;
3163         else
3164             t = send;
3165
3166         sv_setpvn(tmpstr, s, t - s);
3167         av_store(array, line++, tmpstr);
3168         s = t;
3169     }
3170 }
3171
3172 /*
3173 =for apidoc docatch
3174
3175 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3176
3177 0 is used as continue inside eval,
3178
3179 3 is used for a die caught by an inner eval - continue inner loop
3180
3181 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3182 establish a local jmpenv to handle exception traps.
3183
3184 =cut
3185 */
3186 STATIC OP *
3187 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3188 {
3189     int ret;
3190     OP * const oldop = PL_op;
3191     dJMPENV;
3192
3193     assert(CATCH_GET == TRUE);
3194
3195     JMPENV_PUSH(ret);
3196     switch (ret) {
3197     case 0:
3198         PL_op = firstpp(aTHX);
3199  redo_body:
3200         CALLRUNOPS(aTHX);
3201         break;
3202     case 3:
3203         /* die caught by an inner eval - continue inner loop */
3204         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3205             PL_restartjmpenv = NULL;
3206             PL_op = PL_restartop;
3207             PL_restartop = 0;
3208             goto redo_body;
3209         }
3210         /* FALLTHROUGH */
3211     default:
3212         JMPENV_POP;
3213         PL_op = oldop;
3214         JMPENV_JUMP(ret);
3215         NOT_REACHED; /* NOTREACHED */
3216     }
3217     JMPENV_POP;
3218     PL_op = oldop;
3219     return NULL;
3220 }
3221
3222
3223 /*
3224 =for apidoc find_runcv
3225
3226 Locate the CV corresponding to the currently executing sub or eval.
3227 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3228 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3229 entered.  (This allows debuggers to eval in the scope of the breakpoint
3230 rather than in the scope of the debugger itself.)
3231
3232 =cut
3233 */
3234
3235 CV*
3236 Perl_find_runcv(pTHX_ U32 *db_seqp)
3237 {
3238     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3239 }
3240
3241 /* If this becomes part of the API, it might need a better name. */
3242 CV *
3243 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3244 {
3245     PERL_SI      *si;
3246     int          level = 0;
3247
3248     if (db_seqp)
3249         *db_seqp =
3250             PL_curcop == &PL_compiling
3251                 ? PL_cop_seqmax
3252                 : PL_curcop->cop_seq;
3253
3254     for (si = PL_curstackinfo; si; si = si->si_prev) {
3255         I32 ix;
3256         for (ix = si->si_cxix; ix >= 0; ix--) {
3257             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3258             CV *cv = NULL;
3259             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3260                 cv = cx->blk_sub.cv;
3261                 /* skip DB:: code */
3262                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3263                     *db_seqp = cx->blk_oldcop->cop_seq;
3264                     continue;
3265                 }
3266                 if (cx->cx_type & CXp_SUB_RE)
3267                     continue;
3268             }
3269             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3270                 cv = cx->blk_eval.cv;
3271             if (cv) {
3272                 switch (cond) {
3273                 case FIND_RUNCV_padid_eq:
3274                     if (!CvPADLIST(cv)
3275                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3276                         continue;
3277                     return cv;
3278                 case FIND_RUNCV_level_eq:
3279                     if (level++ != arg) continue;
3280                     /* FALLTHROUGH */
3281                 default:
3282                     return cv;
3283                 }
3284             }
3285         }
3286     }
3287     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3288 }
3289
3290
3291 /* Run yyparse() in a setjmp wrapper. Returns:
3292  *   0: yyparse() successful
3293  *   1: yyparse() failed
3294  *   3: yyparse() died
3295  */
3296 STATIC int
3297 S_try_yyparse(pTHX_ int gramtype)
3298 {
3299     int ret;
3300     dJMPENV;
3301
3302     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3303     JMPENV_PUSH(ret);
3304     switch (ret) {
3305     case 0:
3306         ret = yyparse(gramtype) ? 1 : 0;
3307         break;
3308     case 3:
3309         break;
3310     default:
3311         JMPENV_POP;
3312         JMPENV_JUMP(ret);
3313         NOT_REACHED; /* NOTREACHED */
3314     }
3315     JMPENV_POP;
3316     return ret;
3317 }
3318
3319
3320 /* Compile a require/do or an eval ''.
3321  *
3322  * outside is the lexically enclosing CV (if any) that invoked us.
3323  * seq     is the current COP scope value.
3324  * hh      is the saved hints hash, if any.
3325  *
3326  * Returns a bool indicating whether the compile was successful; if so,
3327  * PL_eval_start contains the first op of the compiled code; otherwise,
3328  * pushes undef.
3329  *
3330  * This function is called from two places: pp_require and pp_entereval.
3331  * These can be distinguished by whether PL_op is entereval.
3332  */
3333
3334 STATIC bool
3335 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3336 {
3337     dSP;
3338     OP * const saveop = PL_op;
3339     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3340     COP * const oldcurcop = PL_curcop;
3341     bool in_require = (saveop->op_type == OP_REQUIRE);
3342     int yystatus;
3343     CV *evalcv;
3344
3345     PL_in_eval = (in_require
3346                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3347                   : (EVAL_INEVAL |
3348                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3349                             ? EVAL_RE_REPARSING : 0)));
3350
3351     PUSHMARK(SP);
3352
3353     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3354     CvEVAL_on(evalcv);
3355     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3356     CX_CUR()->blk_eval.cv = evalcv;
3357     CX_CUR()->blk_gimme = gimme;
3358
3359     CvOUTSIDE_SEQ(evalcv) = seq;
3360     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3361
3362     /* set up a scratch pad */
3363
3364     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3365     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3366
3367
3368     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3369
3370     /* make sure we compile in the right package */
3371
3372     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3373         SAVEGENERICSV(PL_curstash);
3374         PL_curstash = (HV *)CopSTASH(PL_curcop);
3375         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3376         else {
3377             SvREFCNT_inc_simple_void(PL_curstash);
3378             save_item(PL_curstname);
3379             sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3380         }
3381     }
3382     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3383     SAVESPTR(PL_beginav);
3384     PL_beginav = newAV();
3385     SAVEFREESV(PL_beginav);
3386     SAVESPTR(PL_unitcheckav);
3387     PL_unitcheckav = newAV();
3388     SAVEFREESV(PL_unitcheckav);
3389
3390
3391     ENTER_with_name("evalcomp");
3392     SAVESPTR(PL_compcv);
3393     PL_compcv = evalcv;
3394
3395     /* try to compile it */
3396
3397     PL_eval_root = NULL;
3398     PL_curcop = &PL_compiling;
3399     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3400         PL_in_eval |= EVAL_KEEPERR;
3401     else
3402         CLEAR_ERRSV();
3403
3404     SAVEHINTS();
3405     if (clear_hints) {
3406         PL_hints = 0;
3407         hv_clear(GvHV(PL_hintgv));
3408     }
3409     else {
3410         PL_hints = saveop->op_private & OPpEVAL_COPHH
3411                      ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3412
3413         /* making 'use re eval' not be in scope when compiling the
3414          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3415          * infinite recursion when S_has_runtime_code() gives a false
3416          * positive: the second time round, HINT_RE_EVAL isn't set so we
3417          * don't bother calling S_has_runtime_code() */
3418         if (PL_in_eval & EVAL_RE_REPARSING)
3419             PL_hints &= ~HINT_RE_EVAL;
3420
3421         if (hh) {
3422             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3423             SvREFCNT_dec(GvHV(PL_hintgv));
3424             GvHV(PL_hintgv) = hh;
3425         }
3426     }
3427     SAVECOMPILEWARNINGS();
3428     if (clear_hints) {
3429         if (PL_dowarn & G_WARN_ALL_ON)
3430             PL_compiling.cop_warnings = pWARN_ALL ;
3431         else if (PL_dowarn & G_WARN_ALL_OFF)
3432             PL_compiling.cop_warnings = pWARN_NONE ;
3433         else
3434             PL_compiling.cop_warnings = pWARN_STD ;
3435     }
3436     else {
3437         PL_compiling.cop_warnings =
3438             DUP_WARNINGS(oldcurcop->cop_warnings);
3439         cophh_free(CopHINTHASH_get(&PL_compiling));
3440         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3441             /* The label, if present, is the first entry on the chain. So rather
3442                than writing a blank label in front of it (which involves an
3443                allocation), just use the next entry in the chain.  */
3444             PL_compiling.cop_hints_hash
3445                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3446             /* Check the assumption that this removed the label.  */
3447             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3448         }
3449         else
3450             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3451     }
3452
3453     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3454
3455     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3456      * so honour CATCH_GET and trap it here if necessary */
3457
3458
3459     /* compile the code */
3460     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3461
3462     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3463         PERL_CONTEXT *cx;
3464         SV *errsv;
3465
3466         PL_op = saveop;
3467         /* note that if yystatus == 3, then the require/eval died during
3468          * compilation, so the EVAL CX block has already been popped, and
3469          * various vars restored */
3470         if (yystatus != 3) {
3471             if (PL_eval_root) {
3472                 op_free(PL_eval_root);
3473                 PL_eval_root = NULL;
3474             }
3475             SP = PL_stack_base + POPMARK;       /* pop original mark */
3476             cx = CX_CUR();
3477             assert(CxTYPE(cx) == CXt_EVAL);
3478             /* pop the CXt_EVAL, and if was a require, croak */
3479             S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3480         }
3481
3482         /* die_unwind() re-croaks when in require, having popped the
3483          * require EVAL context. So we should never catch a require
3484          * exception here */
3485         assert(!in_require);
3486
3487         errsv = ERRSV;
3488         if (!*(SvPV_nolen_const(errsv)))
3489             sv_setpvs(errsv, "Compilation error");
3490
3491         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3492         PUTBACK;
3493         return FALSE;
3494     }
3495
3496     /* Compilation successful. Now clean up */
3497
3498     LEAVE_with_name("evalcomp");
3499
3500     CopLINE_set(&PL_compiling, 0);
3501     SAVEFREEOP(PL_eval_root);
3502     cv_forget_slab(evalcv);
3503
3504     DEBUG_x(dump_eval());
3505
3506     /* Register with debugger: */
3507     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3508         CV * const cv = get_cvs("DB::postponed", 0);
3509         if (cv) {
3510             dSP;
3511             PUSHMARK(SP);
3512             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3513             PUTBACK;
3514             call_sv(MUTABLE_SV(cv), G_DISCARD);
3515         }
3516     }
3517
3518     if (PL_unitcheckav) {
3519         OP *es = PL_eval_start;
3520         call_list(PL_scopestack_ix, PL_unitcheckav);
3521         PL_eval_start = es;
3522     }
3523
3524     CvDEPTH(evalcv) = 1;
3525     SP = PL_stack_base + POPMARK;               /* pop original mark */
3526     PL_op = saveop;                     /* The caller may need it. */
3527     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3528
3529     PUTBACK;
3530     return TRUE;
3531 }
3532
3533 /* Return NULL if the file doesn't exist or isn't a file;
3534  * else return PerlIO_openn().
3535  */
3536
3537 STATIC PerlIO *
3538 S_check_type_and_open(pTHX_ SV *name)
3539 {
3540     Stat_t st;
3541     STRLEN len;
3542     PerlIO * retio;
3543     const char *p = SvPV_const(name, len);
3544     int st_rc;
3545
3546     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3547
3548     /* checking here captures a reasonable error message when
3549      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3550      * user gets a confusing message about looking for the .pmc file
3551      * rather than for the .pm file so do the check in S_doopen_pm when
3552      * PMC is on instead of here. S_doopen_pm calls this func.
3553      * This check prevents a \0 in @INC causing problems.
3554      */
3555 #ifdef PERL_DISABLE_PMC
3556     if (!IS_SAFE_PATHNAME(p, len, "require"))
3557         return NULL;
3558 #endif
3559
3560     /* on Win32 stat is expensive (it does an open() and close() twice and
3561        a couple other IO calls), the open will fail with a dir on its own with
3562        errno EACCES, so only do a stat to separate a dir from a real EACCES
3563        caused by user perms */
3564 #ifndef WIN32
3565     /* we use the value of errno later to see how stat() or open() failed.
3566      * We don't want it set if the stat succeeded but we still failed,
3567      * such as if the name exists, but is a directory */
3568     errno = 0;
3569
3570     st_rc = PerlLIO_stat(p, &st);
3571
3572     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3573         return NULL;
3574     }
3575 #endif
3576
3577     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3578 #ifdef WIN32
3579     /* EACCES stops the INC search early in pp_require to implement
3580        feature RT #113422 */
3581     if(!retio && errno == EACCES) { /* exists but probably a directory */
3582         int eno;
3583         st_rc = PerlLIO_stat(p, &st);
3584         if (st_rc >= 0) {
3585             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3586                 eno = 0;
3587             else
3588                 eno = EACCES;
3589             errno = eno;
3590         }
3591     }
3592 #endif
3593     return retio;
3594 }
3595
3596 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3597  * but first check for bad names (\0) and non-files.
3598  * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3599  * try loading Foo.pmc first.
3600  */
3601 #ifndef PERL_DISABLE_PMC
3602 STATIC PerlIO *
3603 S_doopen_pm(pTHX_ SV *name)
3604 {
3605     STRLEN namelen;
3606     const char *p = SvPV_const(name, namelen);
3607
3608     PERL_ARGS_ASSERT_DOOPEN_PM;
3609
3610     /* check the name before trying for the .pmc name to avoid the
3611      * warning referring to the .pmc which the user probably doesn't
3612      * know or care about
3613      */
3614     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3615         return NULL;
3616
3617     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3618         SV *const pmcsv = sv_newmortal();
3619         PerlIO * pmcio;
3620
3621         SvSetSV_nosteal(pmcsv,name);
3622         sv_catpvs(pmcsv, "c");
3623
3624         pmcio = check_type_and_open(pmcsv);
3625         if (pmcio)
3626             return pmcio;
3627     }
3628     return check_type_and_open(name);
3629 }
3630 #else
3631 #  define doopen_pm(name) check_type_and_open(name)
3632 #endif /* !PERL_DISABLE_PMC */
3633
3634 /* require doesn't search in @INC for absolute names, or when the name is
3635    explicitly relative the current directory: i.e. ./, ../ */
3636 PERL_STATIC_INLINE bool
3637 S_path_is_searchable(const char *name)
3638 {
3639     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3640
3641     if (PERL_FILE_IS_ABSOLUTE(name)
3642 #ifdef WIN32
3643         || (*name == '.' && ((name[1] == '/' ||
3644                              (name[1] == '.' && name[2] == '/'))
3645                          || (name[1] == '\\' ||
3646                              ( name[1] == '.' && name[2] == '\\')))
3647             )
3648 #else
3649         || (*name == '.' && (name[1] == '/' ||
3650                              (name[1] == '.' && name[2] == '/')))
3651 #endif
3652          )
3653     {
3654         return FALSE;
3655     }
3656     else
3657         return TRUE;
3658 }
3659
3660
3661 /* implement 'require 5.010001' */
3662
3663 static OP *
3664 S_require_version(pTHX_ SV *sv)
3665 {
3666     dVAR; dSP;
3667
3668     sv = sv_2mortal(new_version(sv));
3669     if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3670         upg_version(PL_patchlevel, TRUE);
3671     if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3672         if ( vcmp(sv,PL_patchlevel) <= 0 )
3673             DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3674                 SVfARG(sv_2mortal(vnormal(sv))),
3675                 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3676             );
3677     }
3678     else {
3679         if ( vcmp(sv,PL_patchlevel) > 0 ) {
3680             I32 first = 0;
3681             AV *lav;
3682             SV * const req = SvRV(sv);
3683             SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3684
3685             /* get the left hand term */
3686             lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3687
3688             first  = SvIV(*av_fetch(lav,0,0));
3689             if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3690                 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3691                 || av_tindex(lav) > 1            /* FP with > 3 digits */
3692                 || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3693                ) {
3694                 DIE(aTHX_ "Perl %" SVf " required--this is only "
3695                     "%" SVf ", stopped",
3696                     SVfARG(sv_2mortal(vnormal(req))),
3697                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3698                 );
3699             }
3700             else { /* probably 'use 5.10' or 'use 5.8' */
3701                 SV *hintsv;
3702                 I32 second = 0;
3703
3704                 if (av_tindex(lav)>=1)
3705                     second = SvIV(*av_fetch(lav,1,0));
3706
3707                 second /= second >= 600  ? 100 : 10;
3708                 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3709                                        (int)first, (int)second);
3710                 upg_version(hintsv, TRUE);
3711
3712                 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3713                     "--this is only %" SVf ", stopped",
3714                     SVfARG(sv_2mortal(vnormal(req))),
3715                     SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3716                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3717                 );
3718             }
3719         }
3720     }
3721
3722     RETPUSHYES;
3723 }
3724
3725 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3726  * The first form will have already been converted at compile time to
3727  * the second form */
3728
3729 static OP *
3730 S_require_file(pTHX_ SV *sv)
3731 {
3732     dVAR; dSP;
3733
3734     PERL_CONTEXT *cx;
3735     const char *name;
3736     STRLEN len;
3737     char * unixname;
3738     STRLEN unixlen;
3739 #ifdef VMS
3740     int vms_unixname = 0;
3741     char *unixdir;
3742 #endif
3743     /* tryname is the actual pathname (with @INC prefix) which was loaded.
3744      * It's stored as a value in %INC, and used for error messages */
3745     const char *tryname = NULL;
3746     SV *namesv = NULL; /* SV equivalent of tryname */
3747     const U8 gimme = GIMME_V;
3748     int filter_has_file = 0;
3749     PerlIO *tryrsfp = NULL;
3750     SV *filter_cache = NULL;
3751     SV *filter_state = NULL;
3752     SV *filter_sub = NULL;
3753     SV *hook_sv = NULL;
3754     OP *op;
3755     int saved_errno;
3756     bool path_searchable;
3757     I32 old_savestack_ix;
3758     const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3759     const char *const op_name = op_is_require ? "require" : "do";
3760     SV ** svp_cached = NULL;
3761
3762     assert(op_is_require || PL_op->op_type == OP_DOFILE);
3763
3764     if (!SvOK(sv))
3765         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3766     name = SvPV_nomg_const(sv, len);
3767     if (!(name && len > 0 && *name))
3768         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3769
3770 #ifndef VMS
3771         /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3772         if (op_is_require) {
3773                 /* can optimize to only perform one single lookup */
3774                 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3775                 if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
3776         }
3777 #endif
3778
3779     if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3780         if (!op_is_require) {
3781             CLEAR_ERRSV();
3782             RETPUSHUNDEF;
3783         }
3784         DIE(aTHX_ "Can't locate %s:   %s",
3785             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3786                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3787             Strerror(ENOENT));
3788     }
3789     TAINT_PROPER(op_name);
3790
3791     path_searchable = path_is_searchable(name);
3792
3793 #ifdef VMS
3794     /* The key in the %ENV hash is in the syntax of file passed as the argument
3795      * usually this is in UNIX format, but sometimes in VMS format, which
3796      * can result in a module being pulled in more than once.
3797      * To prevent this, the key must be stored in UNIX format if the VMS
3798      * name can be translated to UNIX.
3799      */
3800
3801     if ((unixname =
3802           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3803          != NULL) {
3804         unixlen = strlen(unixname);
3805         vms_unixname = 1;
3806     }
3807     else
3808 #endif
3809     {
3810         /* if not VMS or VMS name can not be translated to UNIX, pass it
3811          * through.
3812          */
3813         unixname = (char *) name;
3814         unixlen = len;
3815     }
3816     if (op_is_require) {
3817         /* reuse the previous hv_fetch result if possible */
3818         SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3819         if ( svp ) {
3820             if (*svp != &PL_sv_undef)
3821                 RETPUSHYES;
3822             else
3823                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3824                             "Compilation failed in require", unixname);
3825         }
3826
3827         /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3828         if (PL_op->op_flags & OPf_KIDS) {
3829             SVOP * const kid = (SVOP*)cUNOP->op_first;
3830
3831             if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3832                 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3833                  * doesn't map to a naughty pathname like /Foo/Bar.pm.
3834                  * Note that the parser will normally detect such errors
3835                  * at compile time before we reach here, but
3836                  * Perl_load_module() can fake up an identical optree
3837                  * without going near the parser, and being able to put
3838                  * anything as the bareword. So we include a duplicate set
3839                  * of checks here at runtime.
3840                  */
3841                 const STRLEN package_len = len - 3;
3842                 const char slashdot[2] = {'/', '.'};
3843 #ifdef DOSISH
3844                 const char backslashdot[2] = {'\\', '.'};
3845 #endif
3846
3847                 /* Disallow *purported* barewords that map to absolute
3848                    filenames, filenames relative to the current or parent
3849                    directory, or (*nix) hidden filenames.  Also sanity check
3850                    that the generated filename ends .pm  */
3851                 if (!path_searchable || len < 3 || name[0] == '.'
3852                     || !memEQ(name + package_len, ".pm", 3))
3853                     DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3854                 if (memchr(name, 0, package_len)) {
3855                     /* diag_listed_as: Bareword in require contains "%s" */
3856                     DIE(aTHX_ "Bareword in require contains \"\\0\"");
3857                 }
3858                 if (ninstr(name, name + package_len, slashdot,
3859                            slashdot + sizeof(slashdot))) {
3860                     /* diag_listed_as: Bareword in require contains "%s" */
3861                     DIE(aTHX_ "Bareword in require contains \"/.\"");
3862                 }
3863 #ifdef DOSISH
3864                 if (ninstr(name, name + package_len, backslashdot,
3865                            backslashdot + sizeof(backslashdot))) {
3866                     /* diag_listed_as: Bareword in require contains "%s" */
3867                     DIE(aTHX_ "Bareword in require contains \"\\.\"");
3868                 }
3869 #endif
3870             }
3871         }
3872     }
3873
3874     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3875
3876     /* Try to locate and open a file, possibly using @INC  */
3877
3878     /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3879      * the file directly rather than via @INC ... */
3880     if (!path_searchable) {
3881         /* At this point, name is SvPVX(sv)  */
3882         tryname = name;
3883         tryrsfp = doopen_pm(sv);
3884     }
3885
3886     /* ... but if we fail, still search @INC for code references;
3887      * these are applied even on on-searchable paths (except
3888      * if we got EACESS).
3889      *
3890      * For searchable paths, just search @INC normally
3891      */
3892     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3893         AV * const ar = GvAVn(PL_incgv);
3894         SSize_t i;
3895 #ifdef VMS
3896         if (vms_unixname)
3897 #endif
3898         {
3899             SV *nsv = sv;
3900             namesv = newSV_type(SVt_PV);
3901             for (i = 0; i <= AvFILL(ar); i++) {
3902                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3903
3904                 SvGETMAGIC(dirsv);
3905                 if (SvROK(dirsv)) {
3906                     int count;
3907                     SV **svp;
3908                     SV *loader = dirsv;
3909
3910                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3911                         && !SvOBJECT(SvRV(loader)))
3912                     {
3913                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3914                         SvGETMAGIC(loader);
3915                     }
3916
3917                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3918                                    PTR2UV(SvRV(dirsv)), name);
3919                     tryname = SvPVX_const(namesv);
3920                     tryrsfp = NULL;
3921
3922                     if (SvPADTMP(nsv)) {
3923                         nsv = sv_newmortal();
3924                         SvSetSV_nosteal(nsv,sv);
3925                     }
3926
3927                     ENTER_with_name("call_INC");
3928                     SAVETMPS;
3929                     EXTEND(SP, 2);
3930
3931                     PUSHMARK(SP);
3932                     PUSHs(dirsv);
3933                     PUSHs(nsv);
3934                     PUTBACK;
3935                     if (SvGMAGICAL(loader)) {
3936                         SV *l = sv_newmortal();
3937                         sv_setsv_nomg(l, loader);
3938                         loader = l;
3939                     }
3940                     if (sv_isobject(loader))
3941                         count = call_method("INC", G_ARRAY);
3942                     else
3943                         count = call_sv(loader, G_ARRAY);
3944                     SPAGAIN;
3945
3946                     if (count > 0) {
3947                         int i = 0;
3948                         SV *arg;
3949
3950                         SP -= count - 1;
3951                         arg = SP[i++];
3952
3953                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3954                             && !isGV_with_GP(SvRV(arg))) {
3955                             filter_cache = SvRV(arg);
3956
3957                             if (i < count) {
3958                                 arg = SP[i++];
3959                             }
3960                         }
3961
3962                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3963                             arg = SvRV(arg);
3964                         }
3965
3966                         if (isGV_with_GP(arg)) {
3967                             IO * const io = GvIO((const GV *)arg);
3968
3969                             ++filter_has_file;
3970
3971                             if (io) {
3972                                 tryrsfp = IoIFP(io);
3973                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3974                                     PerlIO_close(IoOFP(io));
3975                                 }
3976                                 IoIFP(io) = NULL;
3977                                 IoOFP(io) = NULL;
3978                             }
3979
3980                             if (i < count) {
3981                                 arg = SP[i++];
3982                             }
3983                         }
3984
3985                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3986                             filter_sub = arg;
3987                             SvREFCNT_inc_simple_void_NN(filter_sub);
3988
3989                             if (i < count) {
3990                                 filter_state = SP[i];
3991                                 SvREFCNT_inc_simple_void(filter_state);
3992                             }
3993                         }
3994
3995                         if (!tryrsfp && (filter_cache || filter_sub)) {
3996                             tryrsfp = PerlIO_open(BIT_BUCKET,
3997                                                   PERL_SCRIPT_MODE);
3998                         }
3999                         SP--;
4000                     }
4001
4002                     /* FREETMPS may free our filter_cache */
4003                     SvREFCNT_inc_simple_void(filter_cache);
4004
4005                     PUTBACK;
4006                     FREETMPS;
4007                     LEAVE_with_name("call_INC");
4008
4009                     /* Now re-mortalize it. */
4010                     sv_2mortal(filter_cache);
4011
4012                     /* Adjust file name if the hook has set an %INC entry.
4013                        This needs to happen after the FREETMPS above.  */
4014                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4015                     if (svp)
4016                         tryname = SvPV_nolen_const(*svp);
4017
4018                     if (tryrsfp) {
4019                         hook_sv = dirsv;
4020                         break;
4021                     }
4022
4023                     filter_has_file = 0;
4024                     filter_cache = NULL;
4025                     if (filter_state) {
4026                         SvREFCNT_dec_NN(filter_state);
4027                         filter_state = NULL;
4028                     }
4029                     if (filter_sub) {
4030                         SvREFCNT_dec_NN(filter_sub);
4031                         filter_sub = NULL;
4032                     }
4033                 }
4034                 else if (path_searchable) {
4035                     /* match against a plain @INC element (non-searchable
4036                      * paths are only matched against refs in @INC) */
4037                     const char *dir;
4038                     STRLEN dirlen;
4039
4040                     if (SvOK(dirsv)) {
4041                         dir = SvPV_nomg_const(dirsv, dirlen);
4042                     } else {
4043                         dir = "";
4044                         dirlen = 0;
4045                     }
4046
4047                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4048                         continue;
4049 #ifdef VMS
4050                     if ((unixdir =
4051                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4052                          == NULL)
4053                         continue;
4054                     sv_setpv(namesv, unixdir);
4055                     sv_catpv(namesv, unixname);
4056 #elif defined(__SYMBIAN32__)
4057                     if (PL_origfilename[0] &&
4058                         PL_origfilename[1] == ':' &&
4059                         !(dir[0] && dir[1] == ':'))
4060                         Perl_sv_setpvf(aTHX_ namesv,
4061                                        "%c:%s\\%s",
4062                                        PL_origfilename[0],
4063                                        dir, name);
4064                     else
4065                         Perl_sv_setpvf(aTHX_ namesv,
4066                                        "%s\\%s",
4067                                        dir, name);
4068 #else
4069                     /* The equivalent of
4070                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4071                        but without the need to parse the format string, or
4072                        call strlen on either pointer, and with the correct
4073                        allocation up front.  */
4074                     {
4075                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4076
4077                         memcpy(tmp, dir, dirlen);
4078                         tmp +=dirlen;
4079
4080                         /* Avoid '<dir>//<file>' */
4081                         if (!dirlen || *(tmp-1) != '/') {
4082                             *tmp++ = '/';
4083                         } else {
4084                             /* So SvCUR_set reports the correct length below */
4085                             dirlen--;
4086                         }
4087
4088                         /* name came from an SV, so it will have a '\0' at the
4089                            end that we can copy as part of this memcpy().  */
4090                         memcpy(tmp, name, len + 1);
4091
4092                         SvCUR_set(namesv, dirlen + len + 1);
4093                         SvPOK_on(namesv);
4094                     }
4095 #endif
4096                     TAINT_PROPER(op_name);
4097                     tryname = SvPVX_const(namesv);
4098                     tryrsfp = doopen_pm(namesv);
4099                     if (tryrsfp) {
4100                         if (tryname[0] == '.' && tryname[1] == '/') {
4101                             ++tryname;
4102                             while (*++tryname == '/') {}
4103                         }
4104                         break;
4105                     }
4106                     else if (errno == EMFILE || errno == EACCES) {
4107                         /* no point in trying other paths if out of handles;
4108                          * on the other hand, if we couldn't open one of the
4109                          * files, then going on with the search could lead to
4110                          * unexpected results; see perl #113422
4111                          */
4112                         break;
4113                     }
4114                 }
4115             }
4116         }
4117     }
4118
4119     /* at this point we've ether opened a file (tryrsfp) or set errno */
4120
4121     saved_errno = errno; /* sv_2mortal can realloc things */
4122     sv_2mortal(namesv);
4123     if (!tryrsfp) {
4124         /* we failed; croak if require() or return undef if do() */
4125         if (op_is_require) {
4126             if(saved_errno == EMFILE || saved_errno == EACCES) {
4127                 /* diag_listed_as: Can't locate %s */
4128                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4129                     name, tryname, Strerror(saved_errno));
4130             } else {
4131                 if (path_searchable) {          /* did we lookup @INC? */
4132                     AV * const ar = GvAVn(PL_incgv);
4133                     SSize_t i;
4134                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4135                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4136                     const char *e = name + len - 3; /* possible .pm */
4137                     for (i = 0; i <= AvFILL(ar); i++) {
4138                         sv_catpvs(inc, " ");
4139                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4140                     }
4141                     if (e > name && _memEQs(e, ".pm")) {
4142                         const char *c;
4143                         bool utf8 = cBOOL(SvUTF8(sv));
4144
4145                         /* if the filename, when converted from "Foo/Bar.pm"
4146                          * form back to Foo::Bar form, makes a valid
4147                          * package name (i.e. parseable by C<require
4148                          * Foo::Bar>), then emit a hint.
4149                          *
4150                          * this loop is modelled after the one in
4151                          S_parse_ident */
4152                         c = name;
4153                         while (c < e) {
4154                             if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4155                                 c += UTF8SKIP(c);
4156                                 while (c < e && isIDCONT_utf8_safe(
4157                                             (const U8*) c, (const U8*) e))
4158                                     c += UTF8SKIP(c);
4159                             }
4160                             else if (isWORDCHAR_A(*c)) {
4161                                 while (c < e && isWORDCHAR_A(*c))
4162                                     c++;
4163                             }
4164                             else if (*c == '/')
4165                                 c++;
4166                             else
4167                                 break;
4168                         }
4169
4170                         if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4171                             sv_catpv(msg, " (you may need to install the ");
4172                             for (c = name; c < e; c++) {
4173                                 if (*c == '/') {
4174                                     sv_catpvs(msg, "::");
4175                                 }
4176                                 else {
4177                                     sv_catpvn(msg, c, 1);
4178                                 }
4179                             }
4180                             sv_catpv(msg, " module)");
4181                         }
4182                     }
4183                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4184                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4185                     }
4186                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4187                         sv_catpv(msg, " (did you run h2ph?)");
4188                     }
4189
4190                     /* diag_listed_as: Can't locate %s */
4191                     DIE(aTHX_
4192                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4193                         name, msg, inc);
4194                 }
4195             }
4196             DIE(aTHX_ "Can't locate %s", name);
4197         }
4198         else {
4199 #ifdef DEFAULT_INC_EXCLUDES_DOT
4200             Stat_t st;
4201             PerlIO *io = NULL;
4202             dSAVE_ERRNO;
4203             /* the complication is to match the logic from doopen_pm() so
4204              * we don't treat do "sda1" as a previously successful "do".
4205             */
4206             bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4207                 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4208                 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4209             if (io)
4210                 PerlIO_close(io);
4211
4212             RESTORE_ERRNO;
4213             if (do_warn) {
4214                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4215                 "do \"%s\" failed, '.' is no longer in @INC; "
4216                 "did you mean do \"./%s\"?",
4217                 name, name);
4218             }
4219 #endif
4220             CLEAR_ERRSV();
4221             RETPUSHUNDEF;
4222         }
4223     }
4224     else
4225         SETERRNO(0, SS_NORMAL);
4226
4227     /* Update %INC. Assume success here to prevent recursive requirement. */
4228     /* name is never assigned to again, so len is still strlen(name)  */
4229     /* Check whether a hook in @INC has already filled %INC */
4230     if (!hook_sv) {
4231         (void)hv_store(GvHVn(PL_incgv),
4232                        unixname, unixlen, newSVpv(tryname,0),0);
4233     } else {
4234         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4235         if (!svp)
4236             (void)hv_store(GvHVn(PL_incgv),
4237                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4238     }
4239
4240     /* Now parse the file */
4241
4242     old_savestack_ix = PL_savestack_ix;
4243     SAVECOPFILE_FREE(&PL_compiling);
4244     CopFILE_set(&PL_compiling, tryname);
4245     lex_start(NULL, tryrsfp, 0);
4246
4247     if (filter_sub || filter_cache) {
4248         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4249            than hanging another SV from it. In turn, filter_add() optionally
4250            takes the SV to use as the filter (or creates a new SV if passed
4251            NULL), so simply pass in whatever value filter_cache has.  */
4252         SV * const fc = filter_cache ? newSV(0) : NULL;
4253         SV *datasv;
4254         if (fc) sv_copypv(fc, filter_cache);
4255         datasv = filter_add(S_run_user_filter, fc);
4256         IoLINES(datasv) = filter_has_file;
4257         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4258         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4259     }
4260
4261     /* switch to eval mode */
4262     assert(!CATCH_GET);
4263     cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4264     cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4265
4266     SAVECOPLINE(&PL_compiling);
4267     CopLINE_set(&PL_compiling, 0);
4268
4269     PUTBACK;
4270
4271     if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4272         op = PL_eval_start;
4273     else
4274         op = PL_op->op_next;
4275
4276     PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4277
4278     return op;
4279 }
4280
4281
4282 /* also used for: pp_dofile() */
4283
4284 PP(pp_require)
4285 {
4286     RUN_PP_CATCHABLY(Perl_pp_require);
4287
4288     {
4289         dSP;
4290         SV *sv = POPs;
4291         SvGETMAGIC(sv);
4292         PUTBACK;
4293         return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4294             ? S_require_version(aTHX_ sv)
4295             : S_require_file(aTHX_ sv);
4296     }
4297 }
4298
4299
4300 /* This is a op added to hold the hints hash for
4301    pp_entereval. The hash can be modified by the code
4302    being eval'ed, so we return a copy instead. */
4303
4304 PP(pp_hintseval)
4305 {
4306     dSP;
4307     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4308     RETURN;
4309 }
4310
4311
4312 PP(pp_entereval)
4313 {
4314     dSP;
4315     PERL_CONTEXT *cx;
4316     SV *sv;
4317     U8 gimme;
4318     U32 was;
4319     char tbuf[TYPE_DIGITS(long) + 12];
4320     bool saved_delete;
4321     char *tmpbuf;
4322     STRLEN len;
4323     CV* runcv;
4324     U32 seq, lex_flags;
4325     HV *saved_hh;
4326     bool bytes;
4327     I32 old_savestack_ix;
4328
4329     RUN_PP_CATCHABLY(Perl_pp_entereval);
4330
4331     gimme = GIMME_V;
4332     was = PL_breakable_sub_gen;
4333     saved_delete = FALSE;
4334     tmpbuf = tbuf;
4335     lex_flags = 0;
4336     saved_hh = NULL;
4337     bytes = PL_op->op_private & OPpEVAL_BYTES;
4338
4339     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4340         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4341     }
4342     else if (PL_hints & HINT_LOCALIZE_HH || (
4343                 PL_op->op_private & OPpEVAL_COPHH
4344              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4345             )) {
4346         saved_hh = cop_hints_2hv(PL_curcop, 0);
4347         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4348     }
4349     sv = POPs;
4350     if (!SvPOK(sv)) {
4351         /* make sure we've got a plain PV (no overload etc) before testing
4352          * for taint. Making a copy here is probably overkill, but better
4353          * safe than sorry */
4354         STRLEN len;
4355         const char * const p = SvPV_const(sv, len);
4356
4357         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4358         lex_flags |= LEX_START_COPIED;
4359
4360         if (bytes && SvUTF8(sv))
4361             SvPVbyte_force(sv, len);
4362     }
4363     else if (bytes && SvUTF8(sv)) {
4364         /* Don't modify someone else's scalar */
4365         STRLEN len;
4366         sv = newSVsv(sv);
4367         (void)sv_2mortal(sv);
4368         SvPVbyte_force(sv,len);
4369         lex_flags |= LEX_START_COPIED;
4370     }
4371
4372     TAINT_IF(SvTAINTED(sv));
4373     TAINT_PROPER("eval");
4374
4375     old_savestack_ix = PL_savestack_ix;
4376
4377     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4378                            ? LEX_IGNORE_UTF8_HINTS
4379                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4380                         )
4381              );
4382
4383     /* switch to eval mode */
4384
4385     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4386         SV * const temp_sv = sv_newmortal();
4387         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4388                        (unsigned long)++PL_evalseq,
4389                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4390         tmpbuf = SvPVX(temp_sv);
4391         len = SvCUR(temp_sv);
4392     }
4393     else
4394         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4395     SAVECOPFILE_FREE(&PL_compiling);
4396     CopFILE_set(&PL_compiling, tmpbuf+2);
4397     SAVECOPLINE(&PL_compiling);
4398     CopLINE_set(&PL_compiling, 1);
4399     /* special case: an eval '' executed within the DB package gets lexically
4400      * placed in the first non-DB CV rather than the current CV - this
4401      * allows the debugger to execute code, find lexicals etc, in the
4402      * scope of the code being debugged. Passing &seq gets find_runcv
4403      * to do the dirty work for us */
4404     runcv = find_runcv(&seq);
4405
4406     assert(!CATCH_GET);
4407     cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4408     cx_pusheval(cx, PL_op->op_next, NULL);
4409
4410     /* prepare to compile string */
4411
4412     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4413         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4414     else {
4415         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4416            deleting the eval's FILEGV from the stash before gv_check() runs
4417            (i.e. before run-time proper). To work around the coredump that
4418            ensues, we always turn GvMULTI_on for any globals that were
4419            introduced within evals. See force_ident(). GSAR 96-10-12 */
4420         char *const safestr = savepvn(tmpbuf, len);
4421         SAVEDELETE(PL_defstash, safestr, len);
4422         saved_delete = TRUE;
4423     }
4424
4425     PUTBACK;
4426
4427     if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4428         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4429             ?  PERLDB_LINE_OR_SAVESRC
4430             :  PERLDB_SAVESRC_NOSUBS) {
4431             /* Retain the filegv we created.  */
4432         } else if (!saved_delete) {
4433             char *const safestr = savepvn(tmpbuf, len);
4434             SAVEDELETE(PL_defstash, safestr, len);
4435         }
4436         return PL_eval_start;
4437     } else {
4438         /* We have already left the scope set up earlier thanks to the LEAVE
4439            in doeval_compile().  */
4440         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4441             ?  PERLDB_LINE_OR_SAVESRC
4442             :  PERLDB_SAVESRC_INVALID) {
4443             /* Retain the filegv we created.  */
4444         } else if (!saved_delete) {
4445             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4446         }
4447         return PL_op->op_next;
4448     }
4449 }
4450
4451
4452 /* also tail-called by pp_return */
4453
4454 PP(pp_leaveeval)
4455 {
4456     SV **oldsp;
4457     U8 gimme;
4458     PERL_CONTEXT *cx;
4459     OP *retop;
4460     int failed;
4461     CV *evalcv;
4462     bool keep;
4463
4464     PERL_ASYNC_CHECK();
4465
4466     cx = CX_CUR();
4467     assert(CxTYPE(cx) == CXt_EVAL);
4468
4469     oldsp = PL_stack_base + cx->blk_oldsp;
4470     gimme = cx->blk_gimme;
4471
4472     /* did require return a false value? */
4473     failed =    CxOLD_OP_TYPE(cx) == OP_REQUIRE
4474              && !(gimme == G_SCALAR
4475                     ? SvTRUE_NN(*PL_stack_sp)
4476                     : PL_stack_sp > oldsp);
4477
4478     if (gimme == G_VOID) {
4479         PL_stack_sp = oldsp;
4480         /* free now to avoid late-called destructors clobbering $@ */
4481         FREETMPS;
4482     }
4483     else
4484         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4485
4486     /* the cx_popeval does a leavescope, which frees the optree associated
4487      * with eval, which if it frees the nextstate associated with
4488      * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4489      * regex when running under 'use re Debug' because it needs PL_curcop
4490      * to get the current hints. So restore it early.
4491      */
4492     PL_curcop = cx->blk_oldcop;
4493
4494     /* grab this value before cx_popeval restores the old PL_in_eval */
4495     keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4496     retop = cx->blk_eval.retop;
4497     evalcv = cx->blk_eval.cv;
4498 #ifdef DEBUGGING
4499     assert(CvDEPTH(evalcv) == 1);
4500 #endif
4501     CvDEPTH(evalcv) = 0;
4502
4503     /* pop the CXt_EVAL, and if a require failed, croak */
4504     S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4505
4506     if (!keep)
4507         CLEAR_ERRSV();
4508
4509     return retop;
4510 }
4511
4512 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4513    close to the related Perl_create_eval_scope.  */
4514 void
4515 Perl_delete_eval_scope(pTHX)
4516 {
4517     PERL_CONTEXT *cx;
4518
4519     cx = CX_CUR();
4520     CX_LEAVE_SCOPE(cx);
4521     cx_popeval(cx);
4522     cx_popblock(cx);
4523     CX_POP(cx);
4524 }
4525
4526 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4527    also needed by Perl_fold_constants.  */
4528 void
4529 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4530 {
4531     PERL_CONTEXT *cx;
4532     const U8 gimme = GIMME_V;
4533
4534     cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4535                     PL_stack_sp, PL_savestack_ix);
4536     cx_pusheval(cx, retop, NULL);
4537
4538     PL_in_eval = EVAL_INEVAL;
4539     if (flags & G_KEEPERR)
4540         PL_in_eval |= EVAL_KEEPERR;
4541     else
4542         CLEAR_ERRSV();
4543     if (flags & G_FAKINGEVAL) {
4544         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4545     }
4546 }
4547
4548 PP(pp_entertry)
4549 {
4550     RUN_PP_CATCHABLY(Perl_pp_entertry);
4551
4552     assert(!CATCH_GET);
4553     create_eval_scope(cLOGOP->op_other->op_next, 0);
4554     return PL_op->op_next;
4555 }
4556
4557
4558 /* also tail-called by pp_return */
4559
4560 PP(pp_leavetry)
4561 {
4562     SV **oldsp;
4563     U8 gimme;
4564     PERL_CONTEXT *cx;
4565     OP *retop;
4566
4567     PERL_ASYNC_CHECK();
4568
4569     cx = CX_CUR();
4570     assert(CxTYPE(cx) == CXt_EVAL);
4571     oldsp = PL_stack_base + cx->blk_oldsp;
4572     gimme = cx->blk_gimme;
4573
4574     if (gimme == G_VOID) {
4575         PL_stack_sp = oldsp;
4576         /* free now to avoid late-called destructors clobbering $@ */
4577         FREETMPS;
4578     }
4579     else
4580         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4581     CX_LEAVE_SCOPE(cx);
4582     cx_popeval(cx);
4583     cx_popblock(cx);
4584     retop = cx->blk_eval.retop;
4585     CX_POP(cx);
4586
4587     CLEAR_ERRSV();
4588     return retop;
4589 }
4590
4591 PP(pp_entergiven)
4592 {
4593     dSP;
4594     PERL_CONTEXT *cx;
4595     const U8 gimme = GIMME_V;
4596     SV *origsv = DEFSV;
4597     SV *newsv = POPs;
4598
4599     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4600     GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4601
4602     cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4603     cx_pushgiven(cx, origsv);
4604
4605     RETURN;
4606 }
4607
4608 PP(pp_leavegiven)
4609 {
4610     PERL_CONTEXT *cx;
4611     U8 gimme;
4612     SV **oldsp;
4613     PERL_UNUSED_CONTEXT;
4614
4615     cx = CX_CUR();
4616     assert(CxTYPE(cx) == CXt_GIVEN);
4617     oldsp = PL_stack_base + cx->blk_oldsp;
4618     gimme = cx->blk_gimme;
4619
4620     if (gimme == G_VOID)
4621         PL_stack_sp = oldsp;
4622     else
4623         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4624
4625     CX_LEAVE_SCOPE(cx);
4626     cx_popgiven(cx);
4627     cx_popblock(cx);
4628     CX_POP(cx);
4629
4630     return NORMAL;
4631 }
4632
4633 /* Helper routines used by pp_smartmatch */
4634 STATIC PMOP *
4635 S_make_matcher(pTHX_ REGEXP *re)
4636 {
4637     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4638
4639     PERL_ARGS_ASSERT_MAKE_MATCHER;
4640
4641     PM_SETRE(matcher, ReREFCNT_inc(re));
4642
4643     SAVEFREEOP((OP *) matcher);
4644     ENTER_with_name("matcher"); SAVETMPS;
4645     SAVEOP();
4646     return matcher;
4647 }
4648
4649 STATIC bool
4650 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4651 {
4652     dSP;
4653     bool result;
4654
4655     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4656
4657     PL_op = (OP *) matcher;
4658     XPUSHs(sv);
4659     PUTBACK;
4660     (void) Perl_pp_match(aTHX);
4661     SPAGAIN;
4662     result = SvTRUEx(POPs);
4663     PUTBACK;
4664
4665     return result;
4666 }
4667
4668 STATIC void
4669 S_destroy_matcher(pTHX_ PMOP *matcher)
4670 {
4671     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4672     PERL_UNUSED_ARG(matcher);
4673
4674     FREETMPS;
4675     LEAVE_with_name("matcher");
4676 }
4677
4678 /* Do a smart match */
4679 PP(pp_smartmatch)
4680 {
4681     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4682     return do_smartmatch(NULL, NULL, 0);
4683 }
4684
4685 /* This version of do_smartmatch() implements the
4686  * table of smart matches that is found in perlsyn.
4687  */
4688 STATIC OP *
4689 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4690 {
4691     dSP;
4692
4693     bool object_on_left = FALSE;
4694     SV *e = TOPs;       /* e is for 'expression' */
4695     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4696
4697     /* Take care only to invoke mg_get() once for each argument.
4698      * Currently we do this by copying the SV if it's magical. */
4699     if (d) {
4700         if (!copied && SvGMAGICAL(d))
4701             d = sv_mortalcopy(d);
4702     }
4703     else
4704         d = &PL_sv_undef;
4705
4706     assert(e);
4707     if (SvGMAGICAL(e))
4708         e = sv_mortalcopy(e);
4709
4710     /* First of all, handle overload magic of the rightmost argument */
4711     if (SvAMAGIC(e)) {
4712         SV * tmpsv;
4713         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4714         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4715
4716         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4717         if (tmpsv) {
4718             SPAGAIN;
4719             (void)POPs;
4720             SETs(tmpsv);
4721             RETURN;
4722         }
4723         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4724     }
4725
4726     SP -= 2;    /* Pop the values */
4727     PUTBACK;
4728
4729     /* ~~ undef */
4730     if (!SvOK(e)) {
4731         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4732         if (SvOK(d))
4733             RETPUSHNO;
4734         else
4735             RETPUSHYES;
4736     }
4737
4738     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4739         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4740         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4741     }
4742     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4743         object_on_left = TRUE;
4744
4745     /* ~~ sub */
4746     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4747         I32 c;
4748         if (object_on_left) {
4749             goto sm_any_sub; /* Treat objects like scalars */
4750         }
4751         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4752             /* Test sub truth for each key */
4753             HE *he;
4754             bool andedresults = TRUE;
4755             HV *hv = (HV*) SvRV(d);
4756             I32 numkeys = hv_iterinit(hv);
4757             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4758             if (numkeys == 0)
4759                 RETPUSHYES;
4760             while ( (he = hv_iternext(hv)) ) {
4761                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4762                 ENTER_with_name("smartmatch_hash_key_test");
4763                 SAVETMPS;
4764                 PUSHMARK(SP);
4765                 PUSHs(hv_iterkeysv(he));
4766                 PUTBACK;
4767                 c = call_sv(e, G_SCALAR);
4768                 SPAGAIN;
4769                 if (c == 0)
4770                     andedresults = FALSE;
4771                 else
4772                     andedresults = SvTRUEx(POPs) && andedresults;
4773                 FREETMPS;
4774                 LEAVE_with_name("smartmatch_hash_key_test");
4775             }
4776             if (andedresults)
4777                 RETPUSHYES;
4778             else
4779                 RETPUSHNO;
4780         }
4781         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4782             /* Test sub truth for each element */
4783             SSize_t i;
4784             bool andedresults = TRUE;
4785             AV *av = (AV*) SvRV(d);
4786             const I32 len = av_tindex(av);
4787             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4788             if (len == -1)
4789                 RETPUSHYES;
4790             for (i = 0; i <= len; ++i) {
4791                 SV * const * const svp = av_fetch(av, i, FALSE);
4792                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4793                 ENTER_with_name("smartmatch_array_elem_test");
4794                 SAVETMPS;
4795                 PUSHMARK(SP);
4796                 if (svp)
4797                     PUSHs(*svp);
4798                 PUTBACK;
4799                 c = call_sv(e, G_SCALAR);
4800                 SPAGAIN;
4801                 if (c == 0)
4802                     andedresults = FALSE;
4803                 else
4804                     andedresults = SvTRUEx(POPs) && andedresults;
4805                 FREETMPS;
4806                 LEAVE_with_name("smartmatch_array_elem_test");
4807             }
4808             if (andedresults)
4809                 RETPUSHYES;
4810             else
4811                 RETPUSHNO;
4812         }
4813         else {
4814           sm_any_sub:
4815             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4816             ENTER_with_name("smartmatch_coderef");
4817             SAVETMPS;
4818             PUSHMARK(SP);
4819             PUSHs(d);
4820             PUTBACK;
4821             c = call_sv(e, G_SCALAR);
4822             SPAGAIN;
4823             if (c == 0)
4824                 PUSHs(&PL_sv_no);
4825             else if (SvTEMP(TOPs))
4826                 SvREFCNT_inc_void(TOPs);
4827             FREETMPS;
4828             LEAVE_with_name("smartmatch_coderef");
4829             RETURN;
4830         }
4831     }
4832     /* ~~ %hash */
4833     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4834         if (object_on_left) {
4835             goto sm_any_hash; /* Treat objects like scalars */
4836         }
4837         else if (!SvOK(d)) {
4838             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4839             RETPUSHNO;
4840         }
4841         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4842             /* Check that the key-sets are identical */
4843             HE *he;
4844             HV *other_hv = MUTABLE_HV(SvRV(d));
4845             bool tied;
4846             bool other_tied;
4847             U32 this_key_count  = 0,
4848                 other_key_count = 0;
4849             HV *hv = MUTABLE_HV(SvRV(e));
4850
4851             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4852             /* Tied hashes don't know how many keys they have. */
4853             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4854             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4855             if (!tied ) {
4856                 if(other_tied) {
4857                     /* swap HV sides */
4858                     HV * const temp = other_hv;
4859                     other_hv = hv;
4860                     hv = temp;
4861                     tied = TRUE;
4862                     other_tied = FALSE;
4863                 }
4864                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4865                     RETPUSHNO;
4866             }
4867
4868             /* The hashes have the same number of keys, so it suffices
4869                to check that one is a subset of the other. */
4870             (void) hv_iterinit(hv);
4871             while ( (he = hv_iternext(hv)) ) {
4872                 SV *key = hv_iterkeysv(he);
4873
4874                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4875                 ++ this_key_count;
4876
4877                 if(!hv_exists_ent(other_hv, key, 0)) {
4878                     (void) hv_iterinit(hv);     /* reset iterator */
4879                     RETPUSHNO;
4880                 }
4881             }
4882
4883             if (other_tied) {
4884                 (void) hv_iterinit(other_hv);
4885                 while ( hv_iternext(other_hv) )
4886                     ++other_key_count;
4887             }
4888             else
4889                 other_key_count = HvUSEDKEYS(other_hv);
4890
4891             if (this_key_count != other_key_count)
4892                 RETPUSHNO;
4893             else
4894                 RETPUSHYES;
4895         }
4896         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4897             AV * const other_av = MUTABLE_AV(SvRV(d));
4898             const SSize_t other_len = av_tindex(other_av) + 1;
4899             SSize_t i;
4900             HV *hv = MUTABLE_HV(SvRV(e));
4901
4902             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4903             for (i = 0; i < other_len; ++i) {
4904                 SV ** const svp = av_fetch(other_av, i, FALSE);
4905                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4906                 if (svp) {      /* ??? When can this not happen? */
4907                     if (hv_exists_ent(hv, *svp, 0))
4908                         RETPUSHYES;
4909                 }
4910             }
4911             RETPUSHNO;
4912         }
4913         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4914             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4915           sm_regex_hash:
4916             {
4917                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4918                 HE *he;
4919                 HV *hv = MUTABLE_HV(SvRV(e));
4920
4921                 (void) hv_iterinit(hv);
4922                 while ( (he = hv_iternext(hv)) ) {
4923                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4924                     PUTBACK;
4925                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4926                         SPAGAIN;
4927                         (void) hv_iterinit(hv);
4928                         destroy_matcher(matcher);
4929                         RETPUSHYES;
4930                     }
4931                     SPAGAIN;
4932                 }
4933                 destroy_matcher(matcher);
4934                 RETPUSHNO;
4935             }
4936         }
4937         else {
4938           sm_any_hash:
4939             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4940             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4941                 RETPUSHYES;
4942             else
4943                 RETPUSHNO;
4944         }
4945     }
4946     /* ~~ @array */
4947     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4948         if (object_on_left) {
4949             goto sm_any_array; /* Treat objects like scalars */
4950         }
4951         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4952             AV * const other_av = MUTABLE_AV(SvRV(e));
4953             const SSize_t other_len = av_tindex(other_av) + 1;
4954             SSize_t i;
4955
4956             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4957             for (i = 0; i < other_len; ++i) {
4958                 SV ** const svp = av_fetch(other_av, i, FALSE);
4959
4960                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4961                 if (svp) {      /* ??? When can this not happen? */
4962                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4963                         RETPUSHYES;
4964                 }
4965             }
4966             RETPUSHNO;
4967         }
4968         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4969             AV *other_av = MUTABLE_AV(SvRV(d));
4970             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4971             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4972                 RETPUSHNO;
4973             else {
4974                 SSize_t i;
4975                 const SSize_t other_len = av_tindex(other_av);
4976
4977                 if (NULL == seen_this) {
4978                     seen_this = newHV();
4979                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4980                 }
4981                 if (NULL == seen_other) {
4982                     seen_other = newHV();
4983                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4984                 }
4985                 for(i = 0; i <= other_len; ++i) {
4986                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4987                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4988
4989                     if (!this_elem || !other_elem) {
4990                         if ((this_elem && SvOK(*this_elem))
4991                                 || (other_elem && SvOK(*other_elem)))
4992                             RETPUSHNO;
4993                     }
4994                     else if (hv_exists_ent(seen_this,
4995                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4996                             hv_exists_ent(seen_other,
4997                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4998                     {
4999                         if (*this_elem != *other_elem)
5000                             RETPUSHNO;
5001                     }
5002                     else {
5003                         (void)hv_store_ent(seen_this,
5004                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5005                                 &PL_sv_undef, 0);
5006                         (void)hv_store_ent(seen_other,
5007                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5008                                 &PL_sv_undef, 0);
5009                         PUSHs(*other_elem);
5010                         PUSHs(*this_elem);
5011
5012                         PUTBACK;
5013                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
5014                         (void) do_smartmatch(seen_this, seen_other, 0);
5015                         SPAGAIN;
5016                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
5017
5018                         if (!SvTRUEx(POPs))
5019                             RETPUSHNO;
5020                     }
5021                 }
5022                 RETPUSHYES;
5023             }
5024         }
5025         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5026             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
5027           sm_regex_array:
5028             {
5029                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5030                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5031                 SSize_t i;
5032
5033                 for(i = 0; i <= this_len; ++i) {
5034                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5035                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
5036                     PUTBACK;
5037                     if (svp && matcher_matches_sv(matcher, *svp)) {
5038                         SPAGAIN;
5039                         destroy_matcher(matcher);
5040                         RETPUSHYES;
5041                     }
5042                     SPAGAIN;
5043                 }
5044                 destroy_matcher(matcher);
5045                 RETPUSHNO;
5046             }
5047         }
5048         else if (!SvOK(d)) {
5049             /* undef ~~ array */
5050             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5051             SSize_t i;
5052
5053             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
5054             for (i = 0; i <= this_len; ++i) {
5055                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5056                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
5057                 if (!svp || !SvOK(*svp))
5058                     RETPUSHYES;
5059             }
5060             RETPUSHNO;
5061         }
5062         else {
5063           sm_any_array:
5064             {
5065                 SSize_t i;
5066                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5067
5068                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
5069                 for (i = 0; i <= this_len; ++i) {
5070                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5071                     if (!svp)
5072                         continue;
5073
5074                     PUSHs(d);
5075                     PUSHs(*svp);
5076                     PUTBACK;
5077                     /* infinite recursion isn't supposed to happen here */
5078                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
5079                     (void) do_smartmatch(NULL, NULL, 1);
5080                     SPAGAIN;
5081                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
5082                     if (SvTRUEx(POPs))
5083                         RETPUSHYES;
5084                 }
5085                 RETPUSHNO;
5086             }
5087         }
5088     }
5089     /* ~~ qr// */
5090     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5091         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5092             SV *t = d; d = e; e = t;
5093             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
5094             goto sm_regex_hash;
5095         }
5096         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5097             SV *t = d; d = e; e = t;
5098             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
5099             goto sm_regex_array;
5100         }
5101         else {
5102             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5103             bool result;
5104
5105             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
5106             PUTBACK;
5107             result = matcher_matches_sv(matcher, d);
5108             SPAGAIN;
5109             PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5110             destroy_matcher(matcher);
5111             RETURN;
5112         }
5113     }
5114     /* ~~ scalar */
5115     /* See if there is overload magic on left */
5116     else if (object_on_left && SvAMAGIC(d)) {
5117         SV *tmpsv;
5118         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
5119         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
5120         PUSHs(d); PUSHs(e);
5121         PUTBACK;
5122         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5123         if (tmpsv) {
5124             SPAGAIN;
5125             (void)POPs;
5126             SETs(tmpsv);
5127             RETURN;
5128         }
5129         SP -= 2;
5130         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
5131         goto sm_any_scalar;
5132     }
5133     else if (!SvOK(d)) {
5134         /* undef ~~ scalar ; we already know that the scalar is SvOK */
5135         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
5136         RETPUSHNO;
5137     }
5138     else
5139   sm_any_scalar:
5140     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5141         DEBUG_M(if (SvNIOK(e))
5142                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
5143                 else
5144                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
5145         );
5146         /* numeric comparison */
5147         PUSHs(d); PUSHs(e);
5148         PUTBACK;
5149         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5150             (void) Perl_pp_i_eq(aTHX);
5151         else
5152             (void) Perl_pp_eq(aTHX);
5153         SPAGAIN;
5154         if (SvTRUEx(POPs))
5155             RETPUSHYES;
5156         else
5157             RETPUSHNO;
5158     }
5159
5160     /* As a last resort, use string comparison */
5161     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
5162     PUSHs(d); PUSHs(e);
5163     PUTBACK;
5164     return Perl_pp_seq(aTHX);
5165 }
5166
5167 PP(pp_enterwhen)
5168 {
5169     dSP;
5170     PERL_CONTEXT *cx;
5171     const U8 gimme = GIMME_V;
5172
5173     /* This is essentially an optimization: if the match
5174        fails, we don't want to push a context and then
5175        pop it again right away, so we skip straight
5176        to the op that follows the leavewhen.
5177        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5178     */
5179     if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
5180         RETURNOP(cLOGOP->op_other->op_next);
5181
5182     cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5183     cx_pushwhen(cx);
5184
5185     RETURN;
5186 }
5187
5188 PP(pp_leavewhen)
5189 {
5190     I32 cxix;
5191     PERL_CONTEXT *cx;
5192     U8 gimme;
5193     SV **oldsp;
5194
5195     cx = CX_CUR();
5196     assert(CxTYPE(cx) == CXt_WHEN);
5197     gimme = cx->blk_gimme;
5198
5199     cxix = dopoptogivenfor(cxstack_ix);
5200     if (cxix < 0)
5201         /* diag_listed_as: Can't "when" outside a topicalizer */
5202         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5203                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5204
5205     oldsp = PL_stack_base + cx->blk_oldsp;
5206     if (gimme == G_VOID)
5207         PL_stack_sp = oldsp;
5208     else
5209         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5210
5211     /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5212     assert(cxix < cxstack_ix);
5213     dounwind(cxix);
5214
5215     cx = &cxstack[cxix];
5216
5217     if (CxFOREACH(cx)) {
5218         /* emulate pp_next. Note that any stack(s) cleanup will be
5219          * done by the pp_unstack which op_nextop should point to */
5220         cx = CX_CUR();
5221         cx_topblock(cx);
5222         PL_curcop = cx->blk_oldcop;
5223         return cx->blk_loop.my_op->op_nextop;
5224     }
5225     else {
5226         PERL_ASYNC_CHECK();
5227         assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5228         return cx->blk_givwhen.leave_op;
5229     }
5230 }
5231
5232 PP(pp_continue)
5233 {
5234     I32 cxix;
5235     PERL_CONTEXT *cx;
5236     OP *nextop;
5237
5238     cxix = dopoptowhen(cxstack_ix);
5239     if (cxix < 0)
5240         DIE(aTHX_ "Can't \"continue\" outside a when block");
5241
5242     if (cxix < cxstack_ix)
5243         dounwind(cxix);
5244
5245     cx = CX_CUR();
5246     assert(CxTYPE(cx) == CXt_WHEN);
5247     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5248     CX_LEAVE_SCOPE(cx);
5249     cx_popwhen(cx);
5250     cx_popblock(cx);
5251     nextop = cx->blk_givwhen.leave_op->op_next;
5252     CX_POP(cx);
5253
5254     return nextop;
5255 }
5256
5257 PP(pp_break)
5258 {
5259     I32 cxix;
5260     PERL_CONTEXT *cx;
5261
5262     cxix = dopoptogivenfor(cxstack_ix);
5263     if (cxix < 0)
5264         DIE(aTHX_ "Can't \"break\" outside a given block");
5265
5266     cx = &cxstack[cxix];
5267     if (CxFOREACH(cx))
5268         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5269
5270     if (cxix < cxstack_ix)
5271         dounwind(cxix);
5272
5273     /* Restore the sp at the time we entered the given block */
5274     cx = CX_CUR();
5275     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5276
5277     return cx->blk_givwhen.leave_op;
5278 }
5279
5280 static MAGIC *
5281 S_doparseform(pTHX_ SV *sv)
5282 {
5283     STRLEN len;
5284     char *s = SvPV(sv, len);
5285     char *send;
5286     char *base = NULL; /* start of current field */
5287     I32 skipspaces = 0; /* number of contiguous spaces seen */
5288     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5289     bool repeat    = FALSE; /* ~~ seen on this line */
5290     bool postspace = FALSE; /* a text field may need right padding */
5291     U32 *fops;
5292     U32 *fpc;
5293     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5294     I32 arg;
5295     bool ischop;            /* it's a ^ rather than a @ */
5296     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5297     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5298     MAGIC *mg = NULL;
5299     SV *sv_copy;
5300
5301     PERL_ARGS_ASSERT_DOPARSEFORM;
5302
5303     if (len == 0)
5304         Perl_croak(aTHX_ "Null picture in formline");
5305
5306     if (SvTYPE(sv) >= SVt_PVMG) {
5307         /* This might, of course, still return NULL.  */
5308         mg = mg_find(sv, PERL_MAGIC_fm);
5309     } else {
5310         sv_upgrade(sv, SVt_PVMG);
5311     }
5312
5313     if (mg) {
5314         /* still the same as previously-compiled string? */
5315         SV *old = mg->mg_obj;
5316         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5317               && len == SvCUR(old)
5318               && strnEQ(SvPVX(old), s, len)
5319         ) {
5320             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5321             return mg;
5322         }
5323
5324         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5325         Safefree(mg->mg_ptr);
5326         mg->mg_ptr = NULL;
5327         SvREFCNT_dec(old);
5328         mg->mg_obj = NULL;
5329     }
5330     else {
5331         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5332         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5333     }
5334
5335     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5336     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5337     send = s + len;
5338
5339
5340     /* estimate the buffer size needed */
5341     for (base = s; s <= send; s++) {
5342         if (*s == '\n' || *s == '@' || *s == '^')
5343             maxops += 10;
5344     }
5345     s = base;
5346     base = NULL;
5347
5348     Newx(fops, maxops, U32);
5349     fpc = fops;
5350
5351     if (s < send) {
5352         linepc = fpc;
5353         *fpc++ = FF_LINEMARK;
5354         noblank = repeat = FALSE;
5355         base = s;
5356     }
5357
5358     while (s <= send) {
5359         switch (*s++) {
5360         default:
5361             skipspaces = 0;
5362             continue;
5363
5364         case '~':
5365             if (*s == '~') {
5366                 repeat = TRUE;
5367                 skipspaces++;
5368                 s++;
5369             }
5370             noblank = TRUE;
5371             /* FALLTHROUGH */
5372         case ' ': case '\t':
5373             skipspaces++;
5374             continue;
5375         case 0:
5376             if (s < send) {
5377                 skipspaces = 0;
5378                 continue;
5379             }
5380             /* FALLTHROUGH */
5381         case '\n':
5382             arg = s - base;
5383             skipspaces++;
5384             arg -= skipspaces;
5385             if (arg) {
5386                 if (postspace)
5387                     *fpc++ = FF_SPACE;
5388                 *fpc++ = FF_LITERAL;
5389                 *fpc++ = (U32)arg;
5390             }
5391             postspace = FALSE;
5392             if (s <= send)
5393                 skipspaces--;
5394             if (skipspaces) {
5395                 *fpc++ = FF_SKIP;
5396                 *fpc++ = (U32)skipspaces;
5397             }
5398             skipspaces = 0;
5399             if (s <= send)
5400                 *fpc++ = FF_NEWLINE;
5401             if (noblank) {
5402                 *fpc++ = FF_BLANK;
5403                 if (repeat)
5404                     arg = fpc - linepc + 1;
5405                 else
5406                     arg = 0;
5407                 *fpc++ = (U32)arg;
5408             }
5409             if (s < send) {
5410                 linepc = fpc;
5411                 *fpc++ = FF_LINEMARK;
5412                 noblank = repeat = FALSE;
5413                 base = s;
5414             }
5415             else
5416                 s++;
5417             continue;
5418
5419         case '@':
5420         case '^':
5421             ischop = s[-1] == '^';
5422
5423             if (postspace) {
5424                 *fpc++ = FF_SPACE;
5425                 postspace = FALSE;
5426             }
5427             arg = (s - base) - 1;
5428             if (arg) {
5429                 *fpc++ = FF_LITERAL;
5430                 *fpc++ = (U32)arg;
5431             }
5432
5433             base = s - 1;
5434             *fpc++ = FF_FETCH;
5435             if (*s == '*') { /*  @* or ^*  */
5436                 s++;
5437                 *fpc++ = 2;  /* skip the @* or ^* */
5438                 if (ischop) {
5439                     *fpc++ = FF_LINESNGL;
5440                     *fpc++ = FF_CHOP;
5441                 } else
5442                     *fpc++ = FF_LINEGLOB;
5443             }
5444             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5445                 arg = ischop ? FORM_NUM_BLANK : 0;
5446                 base = s - 1;
5447                 while (*s == '#')
5448                     s++;
5449                 if (*s == '.') {
5450                     const char * const f = ++s;
5451                     while (*s == '#')
5452                         s++;
5453                     arg |= FORM_NUM_POINT + (s - f);
5454                 }
5455                 *fpc++ = s - base;              /* fieldsize for FETCH */
5456                 *fpc++ = FF_DECIMAL;
5457                 *fpc++ = (U32)arg;
5458                 unchopnum |= ! ischop;
5459             }
5460             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5461                 arg = ischop ? FORM_NUM_BLANK : 0;
5462                 base = s - 1;
5463                 s++;                                /* skip the '0' first */
5464                 while (*s == '#')
5465                     s++;
5466                 if (*s == '.') {
5467                     const char * const f = ++s;
5468                     while (*s == '#')
5469                         s++;
5470                     arg |= FORM_NUM_POINT + (s - f);
5471                 }
5472                 *fpc++ = s - base;                /* fieldsize for FETCH */
5473                 *fpc++ = FF_0DECIMAL;
5474                 *fpc++ = (U32)arg;
5475                 unchopnum |= ! ischop;
5476             }
5477             else {                              /* text field */
5478                 I32 prespace = 0;
5479                 bool ismore = FALSE;
5480
5481                 if (*s == '>') {
5482                     while (*++s == '>') ;
5483                     prespace = FF_SPACE;
5484                 }
5485                 else if (*s == '|') {
5486                     while (*++s == '|') ;
5487                     prespace = FF_HALFSPACE;
5488                     postspace = TRUE;
5489                 }
5490                 else {
5491                     if (*s == '<')
5492                         while (*++s == '<') ;
5493                     postspace = TRUE;
5494                 }
5495                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5496                     s += 3;
5497                     ismore = TRUE;
5498                 }
5499                 *fpc++ = s - base;              /* fieldsize for FETCH */
5500
5501                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5502
5503                 if (prespace)
5504                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5505                 *fpc++ = FF_ITEM;
5506                 if (ismore)
5507                     *fpc++ = FF_MORE;
5508                 if (ischop)
5509                     *fpc++ = FF_CHOP;
5510             }
5511             base = s;
5512             skipspaces = 0;
5513             continue;
5514         }
5515     }
5516     *fpc++ = FF_END;
5517
5518     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5519     arg = fpc - fops;
5520
5521     mg->mg_ptr = (char *) fops;
5522     mg->mg_len = arg * sizeof(U32);
5523     mg->mg_obj = sv_copy;
5524     mg->mg_flags |= MGf_REFCOUNTED;
5525
5526     if (unchopnum && repeat)
5527         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5528
5529     return mg;
5530 }
5531
5532
5533 STATIC bool
5534 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5535 {
5536     /* Can value be printed in fldsize chars, using %*.*f ? */
5537     NV pwr = 1;
5538     NV eps = 0.5;
5539     bool res = FALSE;
5540     int intsize = fldsize - (value < 0 ? 1 : 0);
5541
5542     if (frcsize & FORM_NUM_POINT)
5543         intsize--;
5544     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5545     intsize -= frcsize;
5546
5547     while (intsize--) pwr *= 10.0;
5548     while (frcsize--) eps /= 10.0;
5549
5550     if( value >= 0 ){
5551         if (value + eps >= pwr)
5552             res = TRUE;
5553     } else {
5554         if (value - eps <= -pwr)
5555             res = TRUE;
5556     }
5557     return res;
5558 }
5559
5560 static I32
5561 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5562 {
5563     SV * const datasv = FILTER_DATA(idx);
5564     const int filter_has_file = IoLINES(datasv);
5565     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5566     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5567     int status = 0;
5568     SV *upstream;
5569     STRLEN got_len;
5570     char *got_p = NULL;
5571     char *prune_from = NULL;
5572     bool read_from_cache = FALSE;
5573     STRLEN umaxlen;
5574     SV *err = NULL;
5575
5576     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5577
5578     assert(maxlen >= 0);
5579     umaxlen = maxlen;
5580
5581     /* I was having segfault trouble under Linux 2.2.5 after a
5582        parse error occurred.  (Had to hack around it with a test
5583        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5584        not sure where the trouble is yet.  XXX */
5585
5586     {
5587         SV *const cache = datasv;
5588         if (SvOK(cache)) {
5589             STRLEN cache_len;
5590             const char *cache_p = SvPV(cache, cache_len);
5591             STRLEN take = 0;
5592
5593             if (umaxlen) {
5594                 /* Running in block mode and we have some cached data already.
5595                  */
5596                 if (cache_len >= umaxlen) {
5597                     /* In fact, so much data we don't even need to call
5598                        filter_read.  */
5599                     take = umaxlen;
5600                 }
5601             } else {
5602                 const char *const first_nl =
5603                     (const char *)memchr(cache_p, '\n', cache_len);
5604                 if (first_nl) {
5605                     take = first_nl + 1 - cache_p;
5606                 }
5607             }
5608             if (take) {
5609                 sv_catpvn(buf_sv, cache_p, take);
5610                 sv_chop(cache, cache_p + take);
5611                 /* Definitely not EOF  */
5612                 return 1;
5613             }
5614
5615             sv_catsv(buf_sv, cache);
5616             if (umaxlen) {
5617                 umaxlen -= cache_len;
5618             }
5619             SvOK_off(cache);
5620             read_from_cache = TRUE;
5621         }
5622     }
5623
5624     /* Filter API says that the filter appends to the contents of the buffer.
5625        Usually the buffer is "", so the details don't matter. But if it's not,
5626        then clearly what it contains is already filtered by this filter, so we
5627        don't want to pass it in a second time.
5628        I'm going to use a mortal in case the upstream filter croaks.  */
5629     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5630         ? sv_newmortal() : buf_sv;
5631     SvUPGRADE(upstream, SVt_PV);
5632
5633     if (filter_has_file) {
5634         status = FILTER_READ(idx+1, upstream, 0);
5635     }
5636
5637     if (filter_sub && status >= 0) {
5638         dSP;
5639         int count;
5640
5641         ENTER_with_name("call_filter_sub");
5642         SAVE_DEFSV;
5643         SAVETMPS;
5644         EXTEND(SP, 2);
5645
5646         DEFSV_set(upstream);
5647         PUSHMARK(SP);
5648         PUSHs(&PL_sv_zero);
5649         if (filter_state) {
5650             PUSHs(filter_state);
5651         }
5652         PUTBACK;
5653         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5654         SPAGAIN;
5655
5656         if (count > 0) {
5657             SV *out = POPs;
5658             SvGETMAGIC(out);
5659             if (SvOK(out)) {
5660                 status = SvIV(out);
5661             }
5662             else {
5663                 SV * const errsv = ERRSV;
5664                 if (SvTRUE_NN(errsv))
5665                     err = newSVsv(errsv);
5666             }
5667         }
5668
5669         PUTBACK;
5670         FREETMPS;
5671         LEAVE_with_name("call_filter_sub");
5672     }
5673
5674     if (SvGMAGICAL(upstream)) {
5675         mg_get(upstream);
5676         if (upstream == buf_sv) mg_free(buf_sv);
5677     }
5678     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5679     if(!err && SvOK(upstream)) {
5680         got_p = SvPV_nomg(upstream, got_len);
5681         if (umaxlen) {
5682             if (got_len > umaxlen) {
5683                 prune_from = got_p + umaxlen;
5684             }
5685         } else {
5686             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5687             if (first_nl && first_nl + 1 < got_p + got_len) {
5688                 /* There's a second line here... */
5689                 prune_from = first_nl + 1;
5690             }
5691         }
5692     }
5693     if (!err && prune_from) {
5694         /* Oh. Too long. Stuff some in our cache.  */
5695         STRLEN cached_len = got_p + got_len - prune_from;
5696         SV *const cache = datasv;
5697
5698         if (SvOK(cache)) {
5699             /* Cache should be empty.  */
5700             assert(!SvCUR(cache));
5701         }
5702
5703         sv_setpvn(cache, prune_from, cached_len);
5704         /* If you ask for block mode, you may well split UTF-8 characters.
5705            "If it breaks, you get to keep both parts"
5706            (Your code is broken if you  don't put them back together again
5707            before something notices.) */
5708         if (SvUTF8(upstream)) {
5709             SvUTF8_on(cache);
5710         }
5711         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5712         else
5713             /* Cannot just use sv_setpvn, as that could free the buffer
5714                before we have a chance to assign it. */
5715             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5716                       got_len - cached_len);
5717         *prune_from = 0;
5718         /* Can't yet be EOF  */
5719         if (status == 0)
5720             status = 1;
5721     }
5722
5723     /* If they are at EOF but buf_sv has something in it, then they may never
5724        have touched the SV upstream, so it may be undefined.  If we naively
5725        concatenate it then we get a warning about use of uninitialised value.
5726     */
5727     if (!err && upstream != buf_sv &&
5728         SvOK(upstream)) {
5729         sv_catsv_nomg(buf_sv, upstream);
5730     }
5731     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5732
5733     if (status <= 0) {
5734         IoLINES(datasv) = 0;
5735         if (filter_state) {
5736             SvREFCNT_dec(filter_state);
5737             IoTOP_GV(datasv) = NULL;
5738         }
5739         if (filter_sub) {
5740             SvREFCNT_dec(filter_sub);
5741             IoBOTTOM_GV(datasv) = NULL;
5742         }
5743         filter_del(S_run_user_filter);
5744     }
5745
5746     if (err)
5747         croak_sv(err);
5748
5749     if (status == 0 && read_from_cache) {
5750         /* If we read some data from the cache (and by getting here it implies
5751            that we emptied the cache) then we aren't yet at EOF, and mustn't
5752            report that to our caller.  */
5753         return 1;
5754     }
5755     return status;
5756 }
5757
5758 /*
5759  * ex: set ts=8 sts=4 sw=4 et:
5760  */