pp_ctl.c

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