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