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