pp_ctl.c

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