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
2649 STATIC OP *
2650 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2651 {
2652     OP **ops = opstack;
2653     static const char* const too_deep = "Target of goto is too deeply nested";
2654
2655     PERL_ARGS_ASSERT_DOFINDLABEL;
2656
2657     if (ops >= oplimit)
2658         Perl_croak(aTHX_ "%s", too_deep);
2659     if (o->op_type == OP_LEAVE ||
2660         o->op_type == OP_SCOPE ||
2661         o->op_type == OP_LEAVELOOP ||
2662         o->op_type == OP_LEAVESUB ||
2663         o->op_type == OP_LEAVETRY ||
2664         o->op_type == OP_LEAVEGIVEN)
2665     {
2666         *ops++ = cUNOPo->op_first;
2667     }
2668     else if (o->op_flags & OPf_KIDS
2669           && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2670         *ops++ = UNENTERABLE;
2671     }
2672     else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2673           && OP_CLASS(o) != OA_LOGOP
2674           && o->op_type != OP_LINESEQ
2675           && o->op_type != OP_SREFGEN
2676           && o->op_type != OP_ENTEREVAL
2677           && o->op_type != OP_RV2CV) {
2678         OP * const kid = cUNOPo->op_first;
2679         if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2680             *ops++ = UNENTERABLE;
2681     }
2682     if (ops >= oplimit)
2683         Perl_croak(aTHX_ "%s", too_deep);
2684     *ops = 0;
2685     if (o->op_flags & OPf_KIDS) {
2686         OP *kid;
2687         /* First try all the kids at this level, since that's likeliest. */
2688         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2689             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2690                 STRLEN kid_label_len;
2691                 U32 kid_label_flags;
2692                 const char *kid_label = CopLABEL_len_flags(kCOP,
2693                                                     &kid_label_len, &kid_label_flags);
2694                 if (kid_label && (
2695                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2696                         (flags & SVf_UTF8)
2697                             ? (bytes_cmp_utf8(
2698                                         (const U8*)kid_label, kid_label_len,
2699                                         (const U8*)label, len) == 0)
2700                             : (bytes_cmp_utf8(
2701                                         (const U8*)label, len,
2702                                         (const U8*)kid_label, kid_label_len) == 0)
2703                     : ( len == kid_label_len && ((kid_label == label)
2704                                     || memEQ(kid_label, label, len)))))
2705                     return kid;
2706             }
2707         }
2708         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2709             if (kid == PL_lastgotoprobe)
2710                 continue;
2711             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2712                 if (ops == opstack)
2713                     *ops++ = kid;
2714                 else if (ops[-1] != UNENTERABLE
2715                       && (ops[-1]->op_type == OP_NEXTSTATE ||
2716                           ops[-1]->op_type == OP_DBSTATE))
2717                     ops[-1] = kid;
2718                 else
2719                     *ops++ = kid;
2720             }
2721             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2722                 return o;
2723         }
2724     }
2725     *ops = 0;
2726     return 0;
2727 }
2728
2729
2730 static void
2731 S_check_op_type(pTHX_ OP * const o)
2732 {
2733     /* Eventually we may want to stack the needed arguments
2734      * for each op.  For now, we punt on the hard ones. */
2735     /* XXX This comment seems to me like wishful thinking.  --sprout */
2736     if (o == UNENTERABLE)
2737         Perl_croak(aTHX_
2738                   "Can't \"goto\" into a binary or list expression");
2739     if (o->op_type == OP_ENTERITER)
2740         Perl_croak(aTHX_
2741                   "Can't \"goto\" into the middle of a foreach loop");
2742     if (o->op_type == OP_ENTERGIVEN)
2743         Perl_croak(aTHX_
2744                   "Can't \"goto\" into a \"given\" block");
2745 }
2746
2747 /* also used for: pp_dump() */
2748
2749 PP(pp_goto)
2750 {
2751     dVAR; dSP;
2752     OP *retop = NULL;
2753     I32 ix;
2754     PERL_CONTEXT *cx;
2755 #define GOTO_DEPTH 64
2756     OP *enterops[GOTO_DEPTH];
2757     const char *label = NULL;
2758     STRLEN label_len = 0;
2759     U32 label_flags = 0;
2760     const bool do_dump = (PL_op->op_type == OP_DUMP);
2761     static const char* const must_have_label = "goto must have label";
2762
2763     if (PL_op->op_flags & OPf_STACKED) {
2764         /* goto EXPR  or  goto &foo */
2765
2766         SV * const sv = POPs;
2767         SvGETMAGIC(sv);
2768
2769         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2770             /* This egregious kludge implements goto &subroutine */
2771             I32 cxix;
2772             PERL_CONTEXT *cx;
2773             CV *cv = MUTABLE_CV(SvRV(sv));
2774             AV *arg = GvAV(PL_defgv);
2775
2776             while (!CvROOT(cv) && !CvXSUB(cv)) {
2777                 const GV * const gv = CvGV(cv);
2778                 if (gv) {
2779                     GV *autogv;
2780                     SV *tmpstr;
2781                     /* autoloaded stub? */
2782                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2783                         continue;
2784                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2785                                           GvNAMELEN(gv),
2786                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2787                     if (autogv && (cv = GvCV(autogv)))
2788                         continue;
2789                     tmpstr = sv_newmortal();
2790                     gv_efullname3(tmpstr, gv, NULL);
2791                     DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2792                 }
2793                 DIE(aTHX_ "Goto undefined subroutine");
2794             }
2795
2796             cxix = dopoptosub(cxstack_ix);
2797             if (cxix < 0) {
2798                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2799             }
2800             cx  = &cxstack[cxix];
2801             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2802             if (CxTYPE(cx) == CXt_EVAL) {
2803                 if (CxREALEVAL(cx))
2804                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2805                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2806                 else
2807                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2808                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2809             }
2810             else if (CxMULTICALL(cx))
2811                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2812
2813             /* First do some returnish stuff. */
2814
2815             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2816             FREETMPS;
2817             if (cxix < cxstack_ix) {
2818                 dounwind(cxix);
2819             }
2820             cx = CX_CUR();
2821             cx_topblock(cx);
2822             SPAGAIN;
2823
2824             /* protect @_ during save stack unwind. */
2825             if (arg)
2826                 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2827
2828             assert(PL_scopestack_ix == cx->blk_oldscopesp);
2829             CX_LEAVE_SCOPE(cx);
2830
2831             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2832                 /* this is part of cx_popsub_args() */
2833                 AV* av = MUTABLE_AV(PAD_SVl(0));
2834                 assert(AvARRAY(MUTABLE_AV(
2835                     PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2836                             CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2837
2838                 /* we are going to donate the current @_ from the old sub
2839                  * to the new sub. This first part of the donation puts a
2840                  * new empty AV in the pad[0] slot of the old sub,
2841                  * unless pad[0] and @_ differ (e.g. if the old sub did
2842                  * local *_ = []); in which case clear the old pad[0]
2843                  * array in the usual way */
2844                 if (av == arg || AvREAL(av))
2845                     clear_defarray(av, av == arg);
2846                 else CLEAR_ARGARRAY(av);
2847             }
2848
2849             /* don't restore PL_comppad here. It won't be needed if the
2850              * sub we're going to is non-XS, but restoring it early then
2851              * croaking (e.g. the "Goto undefined subroutine" below)
2852              * means the CX block gets processed again in dounwind,
2853              * but this time with the wrong PL_comppad */
2854
2855             /* A destructor called during LEAVE_SCOPE could have undefined
2856              * our precious cv.  See bug #99850. */
2857             if (!CvROOT(cv) && !CvXSUB(cv)) {
2858                 const GV * const gv = CvGV(cv);
2859                 if (gv) {
2860                     SV * const tmpstr = sv_newmortal();
2861                     gv_efullname3(tmpstr, gv, NULL);
2862                     DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2863                                SVfARG(tmpstr));
2864                 }
2865                 DIE(aTHX_ "Goto undefined subroutine");
2866             }
2867
2868             if (CxTYPE(cx) == CXt_SUB) {
2869                 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2870                 SvREFCNT_dec_NN(cx->blk_sub.cv);
2871             }
2872
2873             /* Now do some callish stuff. */
2874             if (CvISXSUB(cv)) {
2875                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2876                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2877                 SV** mark;
2878
2879                 ENTER;
2880                 SAVETMPS;
2881                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2882
2883                 /* put GvAV(defgv) back onto stack */
2884                 if (items) {
2885                     EXTEND(SP, items+1); /* @_ could have been extended. */
2886                 }
2887                 mark = SP;
2888                 if (items) {
2889                     SSize_t index;
2890                     bool r = cBOOL(AvREAL(arg));
2891                     for (index=0; index<items; index++)
2892                     {
2893                         SV *sv;
2894                         if (m) {
2895                             SV ** const svp = av_fetch(arg, index, 0);
2896                             sv = svp ? *svp : NULL;
2897                         }
2898                         else sv = AvARRAY(arg)[index];
2899                         SP[index+1] = sv
2900                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2901                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2902                     }
2903                 }
2904                 SP += items;
2905                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2906                     /* Restore old @_ */
2907                     CX_POP_SAVEARRAY(cx);
2908                 }
2909
2910                 retop = cx->blk_sub.retop;
2911                 PL_comppad = cx->blk_sub.prevcomppad;
2912                 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2913
2914                 /* XS subs don't have a CXt_SUB, so pop it;
2915                  * this is a cx_popblock(), less all the stuff we already did
2916                  * for cx_topblock() earlier */
2917                 PL_curcop = cx->blk_oldcop;
2918                 CX_POP(cx);
2919
2920                 /* Push a mark for the start of arglist */
2921                 PUSHMARK(mark);
2922                 PUTBACK;
2923                 (void)(*CvXSUB(cv))(aTHX_ cv);
2924                 LEAVE;
2925                 goto _return;
2926             }
2927             else {
2928                 PADLIST * const padlist = CvPADLIST(cv);
2929
2930                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2931
2932                 /* partial unrolled cx_pushsub(): */
2933
2934                 cx->blk_sub.cv = cv;
2935                 cx->blk_sub.olddepth = CvDEPTH(cv);
2936
2937                 CvDEPTH(cv)++;
2938                 SvREFCNT_inc_simple_void_NN(cv);
2939                 if (CvDEPTH(cv) > 1) {
2940                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2941                         sub_crush_depth(cv);
2942                     pad_push(padlist, CvDEPTH(cv));
2943                 }
2944                 PL_curcop = cx->blk_oldcop;
2945                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2946                 if (CxHASARGS(cx))
2947                 {
2948                     /* second half of donating @_ from the old sub to the
2949                      * new sub: abandon the original pad[0] AV in the
2950                      * new sub, and replace it with the donated @_.
2951                      * pad[0] takes ownership of the extra refcount
2952                      * we gave arg earlier */
2953                     if (arg) {
2954                         SvREFCNT_dec(PAD_SVl(0));
2955                         PAD_SVl(0) = (SV *)arg;
2956                         SvREFCNT_inc_simple_void_NN(arg);
2957                     }
2958
2959                     /* GvAV(PL_defgv) might have been modified on scope
2960                        exit, so point it at arg again. */
2961                     if (arg != GvAV(PL_defgv)) {
2962                         AV * const av = GvAV(PL_defgv);
2963                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2964                         SvREFCNT_dec(av);
2965                     }
2966                 }
2967
2968                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2969                     Perl_get_db_sub(aTHX_ NULL, cv);
2970                     if (PERLDB_GOTO) {
2971                         CV * const gotocv = get_cvs("DB::goto", 0);
2972                         if (gotocv) {
2973                             PUSHMARK( PL_stack_sp );
2974                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2975                             PL_stack_sp--;
2976                         }
2977                     }
2978                 }
2979                 retop = CvSTART(cv);
2980                 goto putback_return;
2981             }
2982         }
2983         else {
2984             /* goto EXPR */
2985             label       = SvPV_nomg_const(sv, label_len);
2986             label_flags = SvUTF8(sv);
2987         }
2988     }
2989     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2990         /* goto LABEL  or  dump LABEL */
2991         label       = cPVOP->op_pv;
2992         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2993         label_len   = strlen(label);
2994     }
2995     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2996
2997     PERL_ASYNC_CHECK();
2998
2999     if (label_len) {
3000         OP *gotoprobe = NULL;
3001         bool leaving_eval = FALSE;
3002         bool in_block = FALSE;
3003         bool pseudo_block = FALSE;
3004         PERL_CONTEXT *last_eval_cx = NULL;
3005
3006         /* find label */
3007
3008         PL_lastgotoprobe = NULL;
3009         *enterops = 0;
3010         for (ix = cxstack_ix; ix >= 0; ix--) {
3011             cx = &cxstack[ix];
3012             switch (CxTYPE(cx)) {
3013             case CXt_EVAL:
3014                 leaving_eval = TRUE;
3015                 if (!CxTRYBLOCK(cx)) {
3016                     gotoprobe = (last_eval_cx ?
3017                                 last_eval_cx->blk_eval.old_eval_root :
3018                                 PL_eval_root);
3019                     last_eval_cx = cx;
3020                     break;
3021                 }
3022                 /* else fall through */
3023             case CXt_LOOP_PLAIN:
3024             case CXt_LOOP_LAZYIV:
3025             case CXt_LOOP_LAZYSV:
3026             case CXt_LOOP_LIST:
3027             case CXt_LOOP_ARY:
3028             case CXt_GIVEN:
3029             case CXt_WHEN:
3030                 gotoprobe = OpSIBLING(cx->blk_oldcop);
3031                 break;
3032             case CXt_SUBST:
3033                 continue;
3034             case CXt_BLOCK:
3035                 if (ix) {
3036                     gotoprobe = OpSIBLING(cx->blk_oldcop);
3037                     in_block = TRUE;
3038                 } else
3039                     gotoprobe = PL_main_root;
3040                 break;
3041             case CXt_SUB:
3042                 gotoprobe = CvROOT(cx->blk_sub.cv);
3043                 pseudo_block = cBOOL(CxMULTICALL(cx));
3044                 break;
3045             case CXt_FORMAT:
3046             case CXt_NULL:
3047                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3048             default:
3049                 if (ix)
3050                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3051                         CxTYPE(cx), (long) ix);
3052                 gotoprobe = PL_main_root;
3053                 break;
3054             }
3055             if (gotoprobe) {
3056                 OP *sibl1, *sibl2;
3057
3058                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3059                                     enterops, enterops + GOTO_DEPTH);
3060                 if (retop)
3061                     break;
3062                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3063                      sibl1->op_type == OP_UNSTACK &&
3064                      (sibl2 = OpSIBLING(sibl1)))
3065                 {
3066                     retop = dofindlabel(sibl2,
3067                                         label, label_len, label_flags, enterops,
3068                                         enterops + GOTO_DEPTH);
3069                     if (retop)
3070                         break;
3071                 }
3072             }
3073             if (pseudo_block)
3074                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3075             PL_lastgotoprobe = gotoprobe;
3076         }
3077         if (!retop)
3078             DIE(aTHX_ "Can't find label %" UTF8f,
3079                        UTF8fARG(label_flags, label_len, label));
3080
3081         /* if we're leaving an eval, check before we pop any frames
3082            that we're not going to punt, otherwise the error
3083            won't be caught */
3084
3085         if (leaving_eval && *enterops && enterops[1]) {
3086             I32 i;
3087             for (i = 1; enterops[i]; i++)
3088                 S_check_op_type(aTHX_ enterops[i]);
3089         }
3090
3091         if (*enterops && enterops[1]) {
3092             I32 i = enterops[1] != UNENTERABLE
3093                  && enterops[1]->op_type == OP_ENTER && in_block
3094                     ? 2
3095                     : 1;
3096             if (enterops[i])
3097                 deprecate("\"goto\" to jump into a construct");
3098         }
3099
3100         /* pop unwanted frames */
3101
3102         if (ix < cxstack_ix) {
3103             if (ix < 0)
3104                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3105             dounwind(ix);
3106             cx = CX_CUR();
3107             cx_topblock(cx);
3108         }
3109
3110         /* push wanted frames */
3111
3112         if (*enterops && enterops[1]) {
3113             OP * const oldop = PL_op;
3114             ix = enterops[1] != UNENTERABLE
3115               && enterops[1]->op_type == OP_ENTER && in_block
3116                    ? 2
3117                    : 1;
3118             for (; enterops[ix]; ix++) {
3119                 PL_op = enterops[ix];
3120                 S_check_op_type(aTHX_ PL_op);
3121                 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3122                                          OP_NAME(PL_op)));
3123                 PL_op->op_ppaddr(aTHX);
3124             }
3125             PL_op = oldop;
3126         }
3127     }
3128
3129     if (do_dump) {
3130 #ifdef VMS
3131         if (!retop) retop = PL_main_start;
3132 #endif
3133         PL_restartop = retop;
3134         PL_do_undump = TRUE;
3135
3136         my_unexec();
3137
3138         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3139         PL_do_undump = FALSE;
3140     }
3141
3142     putback_return:
3143     PL_stack_sp = sp;
3144     _return:
3145     PERL_ASYNC_CHECK();
3146     return retop;
3147 }
3148
3149 PP(pp_exit)
3150 {
3151     dSP;
3152     I32 anum;
3153
3154     if (MAXARG < 1)
3155         anum = 0;
3156     else if (!TOPs) {
3157         anum = 0; (void)POPs;
3158     }
3159     else {
3160         anum = SvIVx(POPs);
3161 #ifdef VMS
3162         if (anum == 1
3163          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3164             anum = 0;
3165         VMSISH_HUSHED  =
3166             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3167 #endif
3168     }
3169     PL_exit_flags |= PERL_EXIT_EXPECTED;
3170     my_exit(anum);
3171     PUSHs(&PL_sv_undef);
3172     RETURN;
3173 }
3174
3175 /* Eval. */
3176
3177 STATIC void
3178 S_save_lines(pTHX_ AV *array, SV *sv)
3179 {
3180     const char *s = SvPVX_const(sv);
3181     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3182     I32 line = 1;
3183
3184     PERL_ARGS_ASSERT_SAVE_LINES;
3185
3186     while (s && s < send) {
3187         const char *t;
3188         SV * const tmpstr = newSV_type(SVt_PVMG);
3189
3190         t = (const char *)memchr(s, '\n', send - s);
3191         if (t)
3192             t++;
3193         else
3194             t = send;
3195
3196         sv_setpvn(tmpstr, s, t - s);
3197         av_store(array, line++, tmpstr);
3198         s = t;
3199     }
3200 }
3201
3202 /*
3203 =for apidoc docatch
3204
3205 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3206
3207 0 is used as continue inside eval,
3208
3209 3 is used for a die caught by an inner eval - continue inner loop
3210
3211 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3212 establish a local jmpenv to handle exception traps.
3213
3214 =cut
3215 */
3216 STATIC OP *
3217 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3218 {
3219     int ret;
3220     OP * const oldop = PL_op;
3221     dJMPENV;
3222
3223     assert(CATCH_GET == TRUE);
3224
3225     JMPENV_PUSH(ret);
3226     switch (ret) {
3227     case 0:
3228         PL_op = firstpp(aTHX);
3229  redo_body:
3230         CALLRUNOPS(aTHX);
3231         break;
3232     case 3:
3233         /* die caught by an inner eval - continue inner loop */
3234         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3235             PL_restartjmpenv = NULL;
3236             PL_op = PL_restartop;
3237             PL_restartop = 0;
3238             goto redo_body;
3239         }
3240         /* FALLTHROUGH */
3241     default:
3242         JMPENV_POP;
3243         PL_op = oldop;
3244         JMPENV_JUMP(ret);
3245         NOT_REACHED; /* NOTREACHED */
3246     }
3247     JMPENV_POP;
3248     PL_op = oldop;
3249     return NULL;
3250 }
3251
3252
3253 /*
3254 =for apidoc find_runcv
3255
3256 Locate the CV corresponding to the currently executing sub or eval.
3257 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3258 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3259 entered.  (This allows debuggers to eval in the scope of the breakpoint
3260 rather than in the scope of the debugger itself.)
3261
3262 =cut
3263 */
3264
3265 CV*
3266 Perl_find_runcv(pTHX_ U32 *db_seqp)
3267 {
3268     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3269 }
3270
3271 /* If this becomes part of the API, it might need a better name. */
3272 CV *
3273 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3274 {
3275     PERL_SI      *si;
3276     int          level = 0;
3277
3278     if (db_seqp)
3279         *db_seqp =
3280             PL_curcop == &PL_compiling
3281                 ? PL_cop_seqmax
3282                 : PL_curcop->cop_seq;
3283
3284     for (si = PL_curstackinfo; si; si = si->si_prev) {
3285         I32 ix;
3286         for (ix = si->si_cxix; ix >= 0; ix--) {
3287             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3288             CV *cv = NULL;
3289             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3290                 cv = cx->blk_sub.cv;
3291                 /* skip DB:: code */
3292                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3293                     *db_seqp = cx->blk_oldcop->cop_seq;
3294                     continue;
3295                 }
3296                 if (cx->cx_type & CXp_SUB_RE)
3297                     continue;
3298             }
3299             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3300                 cv = cx->blk_eval.cv;
3301             if (cv) {
3302                 switch (cond) {
3303                 case FIND_RUNCV_padid_eq:
3304                     if (!CvPADLIST(cv)
3305                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3306                         continue;
3307                     return cv;
3308                 case FIND_RUNCV_level_eq:
3309                     if (level++ != arg) continue;
3310                     /* FALLTHROUGH */
3311                 default:
3312                     return cv;
3313                 }
3314             }
3315         }
3316     }
3317     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3318 }
3319
3320
3321 /* Run yyparse() in a setjmp wrapper. Returns:
3322  *   0: yyparse() successful
3323  *   1: yyparse() failed
3324  *   3: yyparse() died
3325  */
3326 STATIC int
3327 S_try_yyparse(pTHX_ int gramtype)
3328 {
3329     int ret;
3330     dJMPENV;
3331
3332     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3333     JMPENV_PUSH(ret);
3334     switch (ret) {
3335     case 0:
3336         ret = yyparse(gramtype) ? 1 : 0;
3337         break;
3338     case 3:
3339         break;
3340     default:
3341         JMPENV_POP;
3342         JMPENV_JUMP(ret);
3343         NOT_REACHED; /* NOTREACHED */
3344     }
3345     JMPENV_POP;
3346     return ret;
3347 }
3348
3349
3350 /* Compile a require/do or an eval ''.
3351  *
3352  * outside is the lexically enclosing CV (if any) that invoked us.
3353  * seq     is the current COP scope value.
3354  * hh      is the saved hints hash, if any.
3355  *
3356  * Returns a bool indicating whether the compile was successful; if so,
3357  * PL_eval_start contains the first op of the compiled code; otherwise,
3358  * pushes undef.
3359  *
3360  * This function is called from two places: pp_require and pp_entereval.
3361  * These can be distinguished by whether PL_op is entereval.
3362  */
3363
3364 STATIC bool
3365 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3366 {
3367     dSP;
3368     OP * const saveop = PL_op;
3369     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3370     COP * const oldcurcop = PL_curcop;
3371     bool in_require = (saveop->op_type == OP_REQUIRE);
3372     int yystatus;
3373     CV *evalcv;
3374
3375     PL_in_eval = (in_require
3376                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3377                   : (EVAL_INEVAL |
3378                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3379                             ? EVAL_RE_REPARSING : 0)));
3380
3381     PUSHMARK(SP);
3382
3383     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3384     CvEVAL_on(evalcv);
3385     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3386     CX_CUR()->blk_eval.cv = evalcv;
3387     CX_CUR()->blk_gimme = gimme;
3388
3389     CvOUTSIDE_SEQ(evalcv) = seq;
3390     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3391
3392     /* set up a scratch pad */
3393
3394     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3395     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3396
3397
3398     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3399
3400     /* make sure we compile in the right package */
3401
3402     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3403         SAVEGENERICSV(PL_curstash);
3404         PL_curstash = (HV *)CopSTASH(PL_curcop);
3405         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3406         else {
3407             SvREFCNT_inc_simple_void(PL_curstash);
3408             save_item(PL_curstname);
3409             sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3410         }
3411     }
3412     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3413     SAVESPTR(PL_beginav);
3414     PL_beginav = newAV();
3415     SAVEFREESV(PL_beginav);
3416     SAVESPTR(PL_unitcheckav);
3417     PL_unitcheckav = newAV();
3418     SAVEFREESV(PL_unitcheckav);
3419
3420
3421     ENTER_with_name("evalcomp");
3422     SAVESPTR(PL_compcv);
3423     PL_compcv = evalcv;
3424
3425     /* try to compile it */
3426
3427     PL_eval_root = NULL;
3428     PL_curcop = &PL_compiling;
3429     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3430         PL_in_eval |= EVAL_KEEPERR;
3431     else
3432         CLEAR_ERRSV();
3433
3434     SAVEHINTS();
3435     if (clear_hints) {
3436         PL_hints = 0;
3437         hv_clear(GvHV(PL_hintgv));
3438     }
3439     else {
3440         PL_hints = saveop->op_private & OPpEVAL_COPHH
3441                      ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3442
3443         /* making 'use re eval' not be in scope when compiling the
3444          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3445          * infinite recursion when S_has_runtime_code() gives a false
3446          * positive: the second time round, HINT_RE_EVAL isn't set so we
3447          * don't bother calling S_has_runtime_code() */
3448         if (PL_in_eval & EVAL_RE_REPARSING)
3449             PL_hints &= ~HINT_RE_EVAL;
3450
3451         if (hh) {
3452             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3453             SvREFCNT_dec(GvHV(PL_hintgv));
3454             GvHV(PL_hintgv) = hh;
3455         }
3456     }
3457     SAVECOMPILEWARNINGS();
3458     if (clear_hints) {
3459         if (PL_dowarn & G_WARN_ALL_ON)
3460             PL_compiling.cop_warnings = pWARN_ALL ;
3461         else if (PL_dowarn & G_WARN_ALL_OFF)
3462             PL_compiling.cop_warnings = pWARN_NONE ;
3463         else
3464             PL_compiling.cop_warnings = pWARN_STD ;
3465     }
3466     else {
3467         PL_compiling.cop_warnings =
3468             DUP_WARNINGS(oldcurcop->cop_warnings);
3469         cophh_free(CopHINTHASH_get(&PL_compiling));
3470         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3471             /* The label, if present, is the first entry on the chain. So rather
3472                than writing a blank label in front of it (which involves an
3473                allocation), just use the next entry in the chain.  */
3474             PL_compiling.cop_hints_hash
3475                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3476             /* Check the assumption that this removed the label.  */
3477             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3478         }
3479         else
3480             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3481     }
3482
3483     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3484
3485     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3486      * so honour CATCH_GET and trap it here if necessary */
3487
3488
3489     /* compile the code */
3490     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3491
3492     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3493         PERL_CONTEXT *cx;
3494         SV *errsv;
3495
3496         PL_op = saveop;
3497         /* note that if yystatus == 3, then the require/eval died during
3498          * compilation, so the EVAL CX block has already been popped, and
3499          * various vars restored */
3500         if (yystatus != 3) {
3501             if (PL_eval_root) {
3502                 op_free(PL_eval_root);
3503                 PL_eval_root = NULL;
3504             }
3505             SP = PL_stack_base + POPMARK;       /* pop original mark */
3506             cx = CX_CUR();
3507             assert(CxTYPE(cx) == CXt_EVAL);
3508             /* pop the CXt_EVAL, and if was a require, croak */
3509             S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3510         }
3511
3512         /* die_unwind() re-croaks when in require, having popped the
3513          * require EVAL context. So we should never catch a require
3514          * exception here */
3515         assert(!in_require);
3516
3517         errsv = ERRSV;
3518         if (!*(SvPV_nolen_const(errsv)))
3519             sv_setpvs(errsv, "Compilation error");
3520
3521         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3522         PUTBACK;
3523         return FALSE;
3524     }
3525
3526     /* Compilation successful. Now clean up */
3527
3528     LEAVE_with_name("evalcomp");
3529
3530     CopLINE_set(&PL_compiling, 0);
3531     SAVEFREEOP(PL_eval_root);
3532     cv_forget_slab(evalcv);
3533
3534     DEBUG_x(dump_eval());
3535
3536     /* Register with debugger: */
3537     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3538         CV * const cv = get_cvs("DB::postponed", 0);
3539         if (cv) {
3540             dSP;
3541             PUSHMARK(SP);
3542             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3543             PUTBACK;
3544             call_sv(MUTABLE_SV(cv), G_DISCARD);
3545         }
3546     }
3547
3548     if (PL_unitcheckav) {
3549         OP *es = PL_eval_start;
3550         call_list(PL_scopestack_ix, PL_unitcheckav);
3551         PL_eval_start = es;
3552     }
3553
3554     CvDEPTH(evalcv) = 1;
3555     SP = PL_stack_base + POPMARK;               /* pop original mark */
3556     PL_op = saveop;                     /* The caller may need it. */
3557     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3558
3559     PUTBACK;
3560     return TRUE;
3561 }
3562
3563 /* Return NULL if the file doesn't exist or isn't a file;
3564  * else return PerlIO_openn().
3565  */
3566
3567 STATIC PerlIO *
3568 S_check_type_and_open(pTHX_ SV *name)
3569 {
3570     Stat_t st;
3571     STRLEN len;
3572     PerlIO * retio;
3573     const char *p = SvPV_const(name, len);
3574     int st_rc;
3575
3576     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3577
3578     /* checking here captures a reasonable error message when
3579      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3580      * user gets a confusing message about looking for the .pmc file
3581      * rather than for the .pm file so do the check in S_doopen_pm when
3582      * PMC is on instead of here. S_doopen_pm calls this func.
3583      * This check prevents a \0 in @INC causing problems.
3584      */
3585 #ifdef PERL_DISABLE_PMC
3586     if (!IS_SAFE_PATHNAME(p, len, "require"))
3587         return NULL;
3588 #endif
3589
3590     /* on Win32 stat is expensive (it does an open() and close() twice and
3591        a couple other IO calls), the open will fail with a dir on its own with
3592        errno EACCES, so only do a stat to separate a dir from a real EACCES
3593        caused by user perms */
3594 #ifndef WIN32
3595     st_rc = PerlLIO_stat(p, &st);
3596
3597     if (st_rc < 0)
3598         return NULL;
3599     else {
3600         int eno;
3601         if(S_ISBLK(st.st_mode)) {
3602             eno = EINVAL;
3603             goto not_file;
3604         }
3605         else if(S_ISDIR(st.st_mode)) {
3606             eno = EISDIR;
3607             not_file:
3608             errno = eno;
3609             return NULL;
3610         }
3611     }
3612 #endif
3613
3614     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3615 #ifdef WIN32
3616     /* EACCES stops the INC search early in pp_require to implement
3617        feature RT #113422 */
3618     if(!retio && errno == EACCES) { /* exists but probably a directory */
3619         int eno;
3620         st_rc = PerlLIO_stat(p, &st);
3621         if (st_rc >= 0) {
3622             if(S_ISDIR(st.st_mode))
3623                 eno = EISDIR;
3624             else if(S_ISBLK(st.st_mode))
3625                 eno = EINVAL;
3626             else
3627                 eno = EACCES;
3628             errno = eno;
3629         }
3630     }
3631 #endif
3632     return retio;
3633 }
3634
3635 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3636  * but first check for bad names (\0) and non-files.
3637  * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3638  * try loading Foo.pmc first.
3639  */
3640 #ifndef PERL_DISABLE_PMC
3641 STATIC PerlIO *
3642 S_doopen_pm(pTHX_ SV *name)
3643 {
3644     STRLEN namelen;
3645     const char *p = SvPV_const(name, namelen);
3646
3647     PERL_ARGS_ASSERT_DOOPEN_PM;
3648
3649     /* check the name before trying for the .pmc name to avoid the
3650      * warning referring to the .pmc which the user probably doesn't
3651      * know or care about
3652      */
3653     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3654         return NULL;
3655
3656     if (memENDPs(p, namelen, ".pm")) {
3657         SV *const pmcsv = sv_newmortal();
3658         PerlIO * pmcio;
3659
3660         SvSetSV_nosteal(pmcsv,name);
3661         sv_catpvs(pmcsv, "c");
3662
3663         pmcio = check_type_and_open(pmcsv);
3664         if (pmcio)
3665             return pmcio;
3666     }
3667     return check_type_and_open(name);
3668 }
3669 #else
3670 #  define doopen_pm(name) check_type_and_open(name)
3671 #endif /* !PERL_DISABLE_PMC */
3672
3673 /* require doesn't search in @INC for absolute names, or when the name is
3674    explicitly relative the current directory: i.e. ./, ../ */
3675 PERL_STATIC_INLINE bool
3676 S_path_is_searchable(const char *name)
3677 {
3678     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3679
3680     if (PERL_FILE_IS_ABSOLUTE(name)
3681 #ifdef WIN32
3682         || (*name == '.' && ((name[1] == '/' ||
3683                              (name[1] == '.' && name[2] == '/'))
3684                          || (name[1] == '\\' ||
3685                              ( name[1] == '.' && name[2] == '\\')))
3686             )
3687 #else
3688         || (*name == '.' && (name[1] == '/' ||
3689                              (name[1] == '.' && name[2] == '/')))
3690 #endif
3691          )
3692     {
3693         return FALSE;
3694     }
3695     else
3696         return TRUE;
3697 }
3698
3699
3700 /* implement 'require 5.010001' */
3701
3702 static OP *
3703 S_require_version(pTHX_ SV *sv)
3704 {
3705     dVAR; dSP;
3706
3707     sv = sv_2mortal(new_version(sv));
3708     if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3709         upg_version(PL_patchlevel, TRUE);
3710     if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3711         if ( vcmp(sv,PL_patchlevel) <= 0 )
3712             DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3713                 SVfARG(sv_2mortal(vnormal(sv))),
3714                 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3715             );
3716     }
3717     else {
3718         if ( vcmp(sv,PL_patchlevel) > 0 ) {
3719             I32 first = 0;
3720             AV *lav;
3721             SV * const req = SvRV(sv);
3722             SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3723
3724             /* get the left hand term */
3725             lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3726
3727             first  = SvIV(*av_fetch(lav,0,0));
3728             if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3729                 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3730                 || av_tindex(lav) > 1            /* FP with > 3 digits */
3731                 || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3732                ) {
3733                 DIE(aTHX_ "Perl %" SVf " required--this is only "
3734                     "%" SVf ", stopped",
3735                     SVfARG(sv_2mortal(vnormal(req))),
3736                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3737                 );
3738             }
3739             else { /* probably 'use 5.10' or 'use 5.8' */
3740                 SV *hintsv;
3741                 I32 second = 0;
3742
3743                 if (av_tindex(lav)>=1)
3744                     second = SvIV(*av_fetch(lav,1,0));
3745
3746                 second /= second >= 600  ? 100 : 10;
3747                 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3748                                        (int)first, (int)second);
3749                 upg_version(hintsv, TRUE);
3750
3751                 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3752                     "--this is only %" SVf ", stopped",
3753                     SVfARG(sv_2mortal(vnormal(req))),
3754                     SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3755                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3756                 );
3757             }
3758         }
3759     }
3760
3761     RETPUSHYES;
3762 }
3763
3764 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3765  * The first form will have already been converted at compile time to
3766  * the second form */
3767
3768 static OP *
3769 S_require_file(pTHX_ SV *sv)
3770 {
3771     dVAR; dSP;
3772
3773     PERL_CONTEXT *cx;
3774     const char *name;
3775     STRLEN len;
3776     char * unixname;
3777     STRLEN unixlen;
3778 #ifdef VMS
3779     int vms_unixname = 0;
3780     char *unixdir;
3781 #endif
3782     /* tryname is the actual pathname (with @INC prefix) which was loaded.
3783      * It's stored as a value in %INC, and used for error messages */
3784     const char *tryname = NULL;
3785     SV *namesv = NULL; /* SV equivalent of tryname */
3786     const U8 gimme = GIMME_V;
3787     int filter_has_file = 0;
3788     PerlIO *tryrsfp = NULL;
3789     SV *filter_cache = NULL;
3790     SV *filter_state = NULL;
3791     SV *filter_sub = NULL;
3792     SV *hook_sv = NULL;
3793     OP *op;
3794     int saved_errno;
3795     bool path_searchable;
3796     I32 old_savestack_ix;
3797     const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3798     const char *const op_name = op_is_require ? "require" : "do";
3799     SV ** svp_cached = NULL;
3800
3801     assert(op_is_require || PL_op->op_type == OP_DOFILE);
3802
3803     if (!SvOK(sv))
3804         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3805     name = SvPV_nomg_const(sv, len);
3806     if (!(name && len > 0 && *name))
3807         DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3808
3809 #ifndef VMS
3810         /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3811         if (op_is_require) {
3812                 /* can optimize to only perform one single lookup */
3813                 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3814                 if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
3815         }
3816 #endif
3817
3818     if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3819         if (!op_is_require) {
3820             CLEAR_ERRSV();
3821             RETPUSHUNDEF;
3822         }
3823         DIE(aTHX_ "Can't locate %s:   %s",
3824             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3825                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3826             Strerror(ENOENT));
3827     }
3828     TAINT_PROPER(op_name);
3829
3830     path_searchable = path_is_searchable(name);
3831
3832 #ifdef VMS
3833     /* The key in the %ENV hash is in the syntax of file passed as the argument
3834      * usually this is in UNIX format, but sometimes in VMS format, which
3835      * can result in a module being pulled in more than once.
3836      * To prevent this, the key must be stored in UNIX format if the VMS
3837      * name can be translated to UNIX.
3838      */
3839
3840     if ((unixname =
3841           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3842          != NULL) {
3843         unixlen = strlen(unixname);
3844         vms_unixname = 1;
3845     }
3846     else
3847 #endif
3848     {
3849         /* if not VMS or VMS name can not be translated to UNIX, pass it
3850          * through.
3851          */
3852         unixname = (char *) name;
3853         unixlen = len;
3854     }
3855     if (op_is_require) {
3856         /* reuse the previous hv_fetch result if possible */
3857         SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3858         if ( svp ) {
3859             if (*svp != &PL_sv_undef)
3860                 RETPUSHYES;
3861             else
3862                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3863                             "Compilation failed in require", unixname);
3864         }
3865
3866         /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3867         if (PL_op->op_flags & OPf_KIDS) {
3868             SVOP * const kid = (SVOP*)cUNOP->op_first;
3869
3870             if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3871                 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3872                  * doesn't map to a naughty pathname like /Foo/Bar.pm.
3873                  * Note that the parser will normally detect such errors
3874                  * at compile time before we reach here, but
3875                  * Perl_load_module() can fake up an identical optree
3876                  * without going near the parser, and being able to put
3877                  * anything as the bareword. So we include a duplicate set
3878                  * of checks here at runtime.
3879                  */
3880                 const STRLEN package_len = len - 3;
3881                 const char slashdot[2] = {'/', '.'};
3882 #ifdef DOSISH
3883                 const char backslashdot[2] = {'\\', '.'};
3884 #endif
3885
3886                 /* Disallow *purported* barewords that map to absolute
3887                    filenames, filenames relative to the current or parent
3888                    directory, or (*nix) hidden filenames.  Also sanity check
3889                    that the generated filename ends .pm  */
3890                 if (!path_searchable || len < 3 || name[0] == '.'
3891                     || !memEQs(name + package_len, len - package_len, ".pm"))
3892                     DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3893                 if (memchr(name, 0, package_len)) {
3894                     /* diag_listed_as: Bareword in require contains "%s" */
3895                     DIE(aTHX_ "Bareword in require contains \"\\0\"");
3896                 }
3897                 if (ninstr(name, name + package_len, slashdot,
3898                            slashdot + sizeof(slashdot))) {
3899                     /* diag_listed_as: Bareword in require contains "%s" */
3900                     DIE(aTHX_ "Bareword in require contains \"/.\"");
3901                 }
3902 #ifdef DOSISH
3903                 if (ninstr(name, name + package_len, backslashdot,
3904                            backslashdot + sizeof(backslashdot))) {
3905                     /* diag_listed_as: Bareword in require contains "%s" */
3906                     DIE(aTHX_ "Bareword in require contains \"\\.\"");
3907                 }
3908 #endif
3909             }
3910         }
3911     }
3912
3913     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3914
3915     /* Try to locate and open a file, possibly using @INC  */
3916
3917     /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3918      * the file directly rather than via @INC ... */
3919     if (!path_searchable) {
3920         /* At this point, name is SvPVX(sv)  */
3921         tryname = name;
3922         tryrsfp = doopen_pm(sv);
3923     }
3924
3925     /* ... but if we fail, still search @INC for code references;
3926      * these are applied even on on-searchable paths (except
3927      * if we got EACESS).
3928      *
3929      * For searchable paths, just search @INC normally
3930      */
3931     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3932         AV * const ar = GvAVn(PL_incgv);
3933         SSize_t i;
3934 #ifdef VMS
3935         if (vms_unixname)
3936 #endif
3937         {
3938             SV *nsv = sv;
3939             namesv = newSV_type(SVt_PV);
3940             for (i = 0; i <= AvFILL(ar); i++) {
3941                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3942
3943                 SvGETMAGIC(dirsv);
3944                 if (SvROK(dirsv)) {
3945                     int count;
3946                     SV **svp;
3947                     SV *loader = dirsv;
3948
3949                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3950                         && !SvOBJECT(SvRV(loader)))
3951                     {
3952                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3953                         SvGETMAGIC(loader);
3954                     }
3955
3956                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3957                                    PTR2UV(SvRV(dirsv)), name);
3958                     tryname = SvPVX_const(namesv);
3959                     tryrsfp = NULL;
3960
3961                     if (SvPADTMP(nsv)) {
3962                         nsv = sv_newmortal();
3963                         SvSetSV_nosteal(nsv,sv);
3964                     }
3965
3966                     ENTER_with_name("call_INC");
3967                     SAVETMPS;
3968                     EXTEND(SP, 2);
3969
3970                     PUSHMARK(SP);
3971                     PUSHs(dirsv);
3972                     PUSHs(nsv);
3973                     PUTBACK;
3974                     if (SvGMAGICAL(loader)) {
3975                         SV *l = sv_newmortal();
3976                         sv_setsv_nomg(l, loader);
3977                         loader = l;
3978                     }
3979                     if (sv_isobject(loader))
3980                         count = call_method("INC", G_ARRAY);
3981                     else
3982                         count = call_sv(loader, G_ARRAY);
3983                     SPAGAIN;
3984
3985                     if (count > 0) {
3986                         int i = 0;
3987                         SV *arg;
3988
3989                         SP -= count - 1;
3990                         arg = SP[i++];
3991
3992                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3993                             && !isGV_with_GP(SvRV(arg))) {
3994                             filter_cache = SvRV(arg);
3995
3996                             if (i < count) {
3997                                 arg = SP[i++];
3998                             }
3999                         }
4000
4001                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4002                             arg = SvRV(arg);
4003                         }
4004
4005                         if (isGV_with_GP(arg)) {
4006                             IO * const io = GvIO((const GV *)arg);
4007
4008                             ++filter_has_file;
4009
4010                             if (io) {
4011                                 tryrsfp = IoIFP(io);
4012                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4013                                     PerlIO_close(IoOFP(io));
4014                                 }
4015                                 IoIFP(io) = NULL;
4016                                 IoOFP(io) = NULL;
4017                             }
4018
4019                             if (i < count) {
4020                                 arg = SP[i++];
4021                             }
4022                         }
4023
4024                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4025                             filter_sub = arg;
4026                             SvREFCNT_inc_simple_void_NN(filter_sub);
4027
4028                             if (i < count) {
4029                                 filter_state = SP[i];
4030                                 SvREFCNT_inc_simple_void(filter_state);
4031                             }
4032                         }
4033
4034                         if (!tryrsfp && (filter_cache || filter_sub)) {
4035                             tryrsfp = PerlIO_open(BIT_BUCKET,
4036                                                   PERL_SCRIPT_MODE);
4037                         }
4038                         SP--;
4039                     }
4040
4041                     /* FREETMPS may free our filter_cache */
4042                     SvREFCNT_inc_simple_void(filter_cache);
4043
4044                     PUTBACK;
4045                     FREETMPS;
4046                     LEAVE_with_name("call_INC");
4047
4048                     /* Now re-mortalize it. */
4049                     sv_2mortal(filter_cache);
4050
4051                     /* Adjust file name if the hook has set an %INC entry.
4052                        This needs to happen after the FREETMPS above.  */
4053                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4054                     if (svp)
4055                         tryname = SvPV_nolen_const(*svp);
4056
4057                     if (tryrsfp) {
4058                         hook_sv = dirsv;
4059                         break;
4060                     }
4061
4062                     filter_has_file = 0;
4063                     filter_cache = NULL;
4064                     if (filter_state) {
4065                         SvREFCNT_dec_NN(filter_state);
4066                         filter_state = NULL;
4067                     }
4068                     if (filter_sub) {
4069                         SvREFCNT_dec_NN(filter_sub);
4070                         filter_sub = NULL;
4071                     }
4072                 }
4073                 else if (path_searchable) {
4074                     /* match against a plain @INC element (non-searchable
4075                      * paths are only matched against refs in @INC) */
4076                     const char *dir;
4077                     STRLEN dirlen;
4078
4079                     if (SvOK(dirsv)) {
4080                         dir = SvPV_nomg_const(dirsv, dirlen);
4081                     } else {
4082                         dir = "";
4083                         dirlen = 0;
4084                     }
4085
4086                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4087                         continue;
4088 #ifdef VMS
4089                     if ((unixdir =
4090                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4091                          == NULL)
4092                         continue;
4093                     sv_setpv(namesv, unixdir);
4094                     sv_catpv(namesv, unixname);
4095 #elif defined(__SYMBIAN32__)
4096                     if (PL_origfilename[0] &&
4097                         PL_origfilename[1] == ':' &&
4098                         !(dir[0] && dir[1] == ':'))
4099                         Perl_sv_setpvf(aTHX_ namesv,
4100                                        "%c:%s\\%s",
4101                                        PL_origfilename[0],
4102                                        dir, name);
4103                     else
4104                         Perl_sv_setpvf(aTHX_ namesv,
4105                                        "%s\\%s",
4106                                        dir, name);
4107 #else
4108                     /* The equivalent of
4109                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4110                        but without the need to parse the format string, or
4111                        call strlen on either pointer, and with the correct
4112                        allocation up front.  */
4113                     {
4114                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4115
4116                         memcpy(tmp, dir, dirlen);
4117                         tmp +=dirlen;
4118
4119                         /* Avoid '<dir>//<file>' */
4120                         if (!dirlen || *(tmp-1) != '/') {
4121                             *tmp++ = '/';
4122                         } else {
4123                             /* So SvCUR_set reports the correct length below */
4124                             dirlen--;
4125                         }
4126
4127                         /* name came from an SV, so it will have a '\0' at the
4128                            end that we can copy as part of this memcpy().  */
4129                         memcpy(tmp, name, len + 1);
4130
4131                         SvCUR_set(namesv, dirlen + len + 1);
4132                         SvPOK_on(namesv);
4133                     }
4134 #endif
4135                     TAINT_PROPER(op_name);
4136                     tryname = SvPVX_const(namesv);
4137                     tryrsfp = doopen_pm(namesv);
4138                     if (tryrsfp) {
4139                         if (tryname[0] == '.' && tryname[1] == '/') {
4140                             ++tryname;
4141                             while (*++tryname == '/') {}
4142                         }
4143                         break;
4144                     }
4145                     else if (errno == EMFILE || errno == EACCES) {
4146                         /* no point in trying other paths if out of handles;
4147                          * on the other hand, if we couldn't open one of the
4148                          * files, then going on with the search could lead to
4149                          * unexpected results; see perl #113422
4150                          */
4151                         break;
4152                     }
4153                 }
4154             }
4155         }
4156     }
4157
4158     /* at this point we've ether opened a file (tryrsfp) or set errno */
4159
4160     saved_errno = errno; /* sv_2mortal can realloc things */
4161     sv_2mortal(namesv);
4162     if (!tryrsfp) {
4163         /* we failed; croak if require() or return undef if do() */
4164         if (op_is_require) {
4165             if(saved_errno == EMFILE || saved_errno == EACCES) {
4166                 /* diag_listed_as: Can't locate %s */
4167                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4168                     name, tryname, Strerror(saved_errno));
4169             } else {
4170                 if (path_searchable) {          /* did we lookup @INC? */
4171                     AV * const ar = GvAVn(PL_incgv);
4172                     SSize_t i;
4173                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4174                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4175                     for (i = 0; i <= AvFILL(ar); i++) {
4176                         sv_catpvs(inc, " ");
4177                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4178                     }
4179                     if (memENDPs(name, len, ".pm")) {
4180                         const char *e = name + len - (sizeof(".pm") - 1);
4181                         const char *c;
4182                         bool utf8 = cBOOL(SvUTF8(sv));
4183
4184                         /* if the filename, when converted from "Foo/Bar.pm"
4185                          * form back to Foo::Bar form, makes a valid
4186                          * package name (i.e. parseable by C<require
4187                          * Foo::Bar>), then emit a hint.
4188                          *
4189                          * this loop is modelled after the one in
4190                          S_parse_ident */
4191                         c = name;
4192                         while (c < e) {
4193                             if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4194                                 c += UTF8SKIP(c);
4195                                 while (c < e && isIDCONT_utf8_safe(
4196                                             (const U8*) c, (const U8*) e))
4197                                     c += UTF8SKIP(c);
4198                             }
4199                             else if (isWORDCHAR_A(*c)) {
4200                                 while (c < e && isWORDCHAR_A(*c))
4201                                     c++;
4202                             }
4203                             else if (*c == '/')
4204                                 c++;
4205                             else
4206                                 break;
4207                         }
4208
4209                         if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4210                             sv_catpv(msg, " (you may need to install the ");
4211                             for (c = name; c < e; c++) {
4212                                 if (*c == '/') {
4213                                     sv_catpvs(msg, "::");
4214                                 }
4215                                 else {
4216                                     sv_catpvn(msg, c, 1);
4217                                 }
4218                             }
4219                             sv_catpv(msg, " module)");
4220                         }
4221                     }
4222                     else if (memENDs(name, len, ".h")) {
4223                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4224                     }
4225                     else if (memENDs(name, len, ".ph")) {
4226                         sv_catpv(msg, " (did you run h2ph?)");
4227                     }
4228
4229                     /* diag_listed_as: Can't locate %s */
4230                     DIE(aTHX_
4231                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4232                         name, msg, inc);
4233                 }
4234             }
4235             DIE(aTHX_ "Can't locate %s", name);
4236         }
4237         else {
4238 #ifdef DEFAULT_INC_EXCLUDES_DOT
4239             Stat_t st;
4240             PerlIO *io = NULL;
4241             dSAVE_ERRNO;
4242             /* the complication is to match the logic from doopen_pm() so
4243              * we don't treat do "sda1" as a previously successful "do".
4244             */
4245             bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4246                 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4247                 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4248             if (io)
4249                 PerlIO_close(io);
4250
4251             RESTORE_ERRNO;
4252             if (do_warn) {
4253                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4254                 "do \"%s\" failed, '.' is no longer in @INC; "
4255                 "did you mean do \"./%s\"?",
4256                 name, name);
4257             }
4258 #endif
4259             CLEAR_ERRSV();
4260             RETPUSHUNDEF;
4261         }
4262     }
4263     else
4264         SETERRNO(0, SS_NORMAL);
4265
4266     /* Update %INC. Assume success here to prevent recursive requirement. */
4267     /* name is never assigned to again, so len is still strlen(name)  */
4268     /* Check whether a hook in @INC has already filled %INC */
4269     if (!hook_sv) {
4270         (void)hv_store(GvHVn(PL_incgv),
4271                        unixname, unixlen, newSVpv(tryname,0),0);
4272     } else {
4273         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4274         if (!svp)
4275             (void)hv_store(GvHVn(PL_incgv),
4276                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4277     }
4278
4279     /* Now parse the file */
4280
4281     old_savestack_ix = PL_savestack_ix;
4282     SAVECOPFILE_FREE(&PL_compiling);
4283     CopFILE_set(&PL_compiling, tryname);
4284     lex_start(NULL, tryrsfp, 0);
4285
4286     if (filter_sub || filter_cache) {
4287         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4288            than hanging another SV from it. In turn, filter_add() optionally
4289            takes the SV to use as the filter (or creates a new SV if passed
4290            NULL), so simply pass in whatever value filter_cache has.  */
4291         SV * const fc = filter_cache ? newSV(0) : NULL;
4292         SV *datasv;
4293         if (fc) sv_copypv(fc, filter_cache);
4294         datasv = filter_add(S_run_user_filter, fc);
4295         IoLINES(datasv) = filter_has_file;
4296         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4297         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4298     }
4299
4300     /* switch to eval mode */
4301     assert(!CATCH_GET);
4302     cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4303     cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4304
4305     SAVECOPLINE(&PL_compiling);
4306     CopLINE_set(&PL_compiling, 0);
4307
4308     PUTBACK;
4309
4310     if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4311         op = PL_eval_start;
4312     else
4313         op = PL_op->op_next;
4314
4315     PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4316
4317     return op;
4318 }
4319
4320
4321 /* also used for: pp_dofile() */
4322
4323 PP(pp_require)
4324 {
4325     RUN_PP_CATCHABLY(Perl_pp_require);
4326
4327     {
4328         dSP;
4329         SV *sv = POPs;
4330         SvGETMAGIC(sv);
4331         PUTBACK;
4332         return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4333             ? S_require_version(aTHX_ sv)
4334             : S_require_file(aTHX_ sv);
4335     }
4336 }
4337
4338
4339 /* This is a op added to hold the hints hash for
4340    pp_entereval. The hash can be modified by the code
4341    being eval'ed, so we return a copy instead. */
4342
4343 PP(pp_hintseval)
4344 {
4345     dSP;
4346     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4347     RETURN;
4348 }
4349
4350
4351 PP(pp_entereval)
4352 {
4353     dSP;
4354     PERL_CONTEXT *cx;
4355     SV *sv;
4356     U8 gimme;
4357     U32 was;
4358     char tbuf[TYPE_DIGITS(long) + 12];
4359     bool saved_delete;
4360     char *tmpbuf;
4361     STRLEN len;
4362     CV* runcv;
4363     U32 seq, lex_flags;
4364     HV *saved_hh;
4365     bool bytes;
4366     I32 old_savestack_ix;
4367
4368     RUN_PP_CATCHABLY(Perl_pp_entereval);
4369
4370     gimme = GIMME_V;
4371     was = PL_breakable_sub_gen;
4372     saved_delete = FALSE;
4373     tmpbuf = tbuf;
4374     lex_flags = 0;
4375     saved_hh = NULL;
4376     bytes = PL_op->op_private & OPpEVAL_BYTES;
4377
4378     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4379         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4380     }
4381     else if (PL_hints & HINT_LOCALIZE_HH || (
4382                 PL_op->op_private & OPpEVAL_COPHH
4383              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4384             )) {
4385         saved_hh = cop_hints_2hv(PL_curcop, 0);
4386         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4387     }
4388     sv = POPs;
4389     if (!SvPOK(sv)) {
4390         /* make sure we've got a plain PV (no overload etc) before testing
4391          * for taint. Making a copy here is probably overkill, but better
4392          * safe than sorry */
4393         STRLEN len;
4394         const char * const p = SvPV_const(sv, len);
4395
4396         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4397         lex_flags |= LEX_START_COPIED;
4398
4399         if (bytes && SvUTF8(sv))
4400             SvPVbyte_force(sv, len);
4401     }
4402     else if (bytes && SvUTF8(sv)) {
4403         /* Don't modify someone else's scalar */
4404         STRLEN len;
4405         sv = newSVsv(sv);
4406         (void)sv_2mortal(sv);
4407         SvPVbyte_force(sv,len);
4408         lex_flags |= LEX_START_COPIED;
4409     }
4410
4411     TAINT_IF(SvTAINTED(sv));
4412     TAINT_PROPER("eval");
4413
4414     old_savestack_ix = PL_savestack_ix;
4415
4416     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4417                            ? LEX_IGNORE_UTF8_HINTS
4418                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4419                         )
4420              );
4421
4422     /* switch to eval mode */
4423
4424     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4425         SV * const temp_sv = sv_newmortal();
4426         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4427                        (unsigned long)++PL_evalseq,
4428                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4429         tmpbuf = SvPVX(temp_sv);
4430         len = SvCUR(temp_sv);
4431     }
4432     else
4433         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4434     SAVECOPFILE_FREE(&PL_compiling);
4435     CopFILE_set(&PL_compiling, tmpbuf+2);
4436     SAVECOPLINE(&PL_compiling);
4437     CopLINE_set(&PL_compiling, 1);
4438     /* special case: an eval '' executed within the DB package gets lexically
4439      * placed in the first non-DB CV rather than the current CV - this
4440      * allows the debugger to execute code, find lexicals etc, in the
4441      * scope of the code being debugged. Passing &seq gets find_runcv
4442      * to do the dirty work for us */
4443     runcv = find_runcv(&seq);
4444
4445     assert(!CATCH_GET);
4446     cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4447     cx_pusheval(cx, PL_op->op_next, NULL);
4448
4449     /* prepare to compile string */
4450
4451     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4452         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4453     else {
4454         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4455            deleting the eval's FILEGV from the stash before gv_check() runs
4456            (i.e. before run-time proper). To work around the coredump that
4457            ensues, we always turn GvMULTI_on for any globals that were
4458            introduced within evals. See force_ident(). GSAR 96-10-12 */
4459         char *const safestr = savepvn(tmpbuf, len);
4460         SAVEDELETE(PL_defstash, safestr, len);
4461         saved_delete = TRUE;
4462     }
4463
4464     PUTBACK;
4465
4466     if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4467         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4468             ?  PERLDB_LINE_OR_SAVESRC
4469             :  PERLDB_SAVESRC_NOSUBS) {
4470             /* Retain the filegv we created.  */
4471         } else if (!saved_delete) {
4472             char *const safestr = savepvn(tmpbuf, len);
4473             SAVEDELETE(PL_defstash, safestr, len);
4474         }
4475         return PL_eval_start;
4476     } else {
4477         /* We have already left the scope set up earlier thanks to the LEAVE
4478            in doeval_compile().  */
4479         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4480             ?  PERLDB_LINE_OR_SAVESRC
4481             :  PERLDB_SAVESRC_INVALID) {
4482             /* Retain the filegv we created.  */
4483         } else if (!saved_delete) {
4484             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4485         }
4486         return PL_op->op_next;
4487     }
4488 }
4489
4490
4491 /* also tail-called by pp_return */
4492
4493 PP(pp_leaveeval)
4494 {
4495     SV **oldsp;
4496     U8 gimme;
4497     PERL_CONTEXT *cx;
4498     OP *retop;
4499     int failed;
4500     CV *evalcv;
4501     bool keep;
4502
4503     PERL_ASYNC_CHECK();
4504
4505     cx = CX_CUR();
4506     assert(CxTYPE(cx) == CXt_EVAL);
4507
4508     oldsp = PL_stack_base + cx->blk_oldsp;
4509     gimme = cx->blk_gimme;
4510
4511     /* did require return a false value? */
4512     failed =    CxOLD_OP_TYPE(cx) == OP_REQUIRE
4513              && !(gimme == G_SCALAR
4514                     ? SvTRUE_NN(*PL_stack_sp)
4515                     : PL_stack_sp > oldsp);
4516
4517     if (gimme == G_VOID) {
4518         PL_stack_sp = oldsp;
4519         /* free now to avoid late-called destructors clobbering $@ */
4520         FREETMPS;
4521     }
4522     else
4523         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4524
4525     /* the cx_popeval does a leavescope, which frees the optree associated
4526      * with eval, which if it frees the nextstate associated with
4527      * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4528      * regex when running under 'use re Debug' because it needs PL_curcop
4529      * to get the current hints. So restore it early.
4530      */
4531     PL_curcop = cx->blk_oldcop;
4532
4533     /* grab this value before cx_popeval restores the old PL_in_eval */
4534     keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4535     retop = cx->blk_eval.retop;
4536     evalcv = cx->blk_eval.cv;
4537 #ifdef DEBUGGING
4538     assert(CvDEPTH(evalcv) == 1);
4539 #endif
4540     CvDEPTH(evalcv) = 0;
4541
4542     /* pop the CXt_EVAL, and if a require failed, croak */
4543     S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4544
4545     if (!keep)
4546         CLEAR_ERRSV();
4547
4548     return retop;
4549 }
4550
4551 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4552    close to the related Perl_create_eval_scope.  */
4553 void
4554 Perl_delete_eval_scope(pTHX)
4555 {
4556     PERL_CONTEXT *cx;
4557
4558     cx = CX_CUR();
4559     CX_LEAVE_SCOPE(cx);
4560     cx_popeval(cx);
4561     cx_popblock(cx);
4562     CX_POP(cx);
4563 }
4564
4565 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4566    also needed by Perl_fold_constants.  */
4567 void
4568 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4569 {
4570     PERL_CONTEXT *cx;
4571     const U8 gimme = GIMME_V;
4572
4573     cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4574                     PL_stack_sp, PL_savestack_ix);
4575     cx_pusheval(cx, retop, NULL);
4576
4577     PL_in_eval = EVAL_INEVAL;
4578     if (flags & G_KEEPERR)
4579         PL_in_eval |= EVAL_KEEPERR;
4580     else
4581         CLEAR_ERRSV();
4582     if (flags & G_FAKINGEVAL) {
4583         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4584     }
4585 }
4586
4587 PP(pp_entertry)
4588 {
4589     RUN_PP_CATCHABLY(Perl_pp_entertry);
4590
4591     assert(!CATCH_GET);
4592     create_eval_scope(cLOGOP->op_other->op_next, 0);
4593     return PL_op->op_next;
4594 }
4595
4596
4597 /* also tail-called by pp_return */
4598
4599 PP(pp_leavetry)
4600 {
4601     SV **oldsp;
4602     U8 gimme;
4603     PERL_CONTEXT *cx;
4604     OP *retop;
4605
4606     PERL_ASYNC_CHECK();
4607
4608     cx = CX_CUR();
4609     assert(CxTYPE(cx) == CXt_EVAL);
4610     oldsp = PL_stack_base + cx->blk_oldsp;
4611     gimme = cx->blk_gimme;
4612
4613     if (gimme == G_VOID) {
4614         PL_stack_sp = oldsp;
4615         /* free now to avoid late-called destructors clobbering $@ */
4616         FREETMPS;
4617     }
4618     else
4619         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4620     CX_LEAVE_SCOPE(cx);
4621     cx_popeval(cx);
4622     cx_popblock(cx);
4623     retop = cx->blk_eval.retop;
4624     CX_POP(cx);
4625
4626     CLEAR_ERRSV();
4627     return retop;
4628 }
4629
4630 PP(pp_entergiven)
4631 {
4632     dSP;
4633     PERL_CONTEXT *cx;
4634     const U8 gimme = GIMME_V;
4635     SV *origsv = DEFSV;
4636     SV *newsv = POPs;
4637
4638     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4639     GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4640
4641     cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4642     cx_pushgiven(cx, origsv);
4643
4644     RETURN;
4645 }
4646
4647 PP(pp_leavegiven)
4648 {
4649     PERL_CONTEXT *cx;
4650     U8 gimme;
4651     SV **oldsp;
4652     PERL_UNUSED_CONTEXT;
4653
4654     cx = CX_CUR();
4655     assert(CxTYPE(cx) == CXt_GIVEN);
4656     oldsp = PL_stack_base + cx->blk_oldsp;
4657     gimme = cx->blk_gimme;
4658
4659     if (gimme == G_VOID)
4660         PL_stack_sp = oldsp;
4661     else
4662         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4663
4664     CX_LEAVE_SCOPE(cx);
4665     cx_popgiven(cx);
4666     cx_popblock(cx);
4667     CX_POP(cx);
4668
4669     return NORMAL;
4670 }
4671
4672 /* Helper routines used by pp_smartmatch */
4673 STATIC PMOP *
4674 S_make_matcher(pTHX_ REGEXP *re)
4675 {
4676     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4677
4678     PERL_ARGS_ASSERT_MAKE_MATCHER;
4679
4680     PM_SETRE(matcher, ReREFCNT_inc(re));
4681
4682     SAVEFREEOP((OP *) matcher);
4683     ENTER_with_name("matcher"); SAVETMPS;
4684     SAVEOP();
4685     return matcher;
4686 }
4687
4688 STATIC bool
4689 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4690 {
4691     dSP;
4692     bool result;
4693
4694     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4695
4696     PL_op = (OP *) matcher;
4697     XPUSHs(sv);
4698     PUTBACK;
4699     (void) Perl_pp_match(aTHX);
4700     SPAGAIN;
4701     result = SvTRUEx(POPs);
4702     PUTBACK;
4703
4704     return result;
4705 }
4706
4707 STATIC void
4708 S_destroy_matcher(pTHX_ PMOP *matcher)
4709 {
4710     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4711     PERL_UNUSED_ARG(matcher);
4712
4713     FREETMPS;
4714     LEAVE_with_name("matcher");
4715 }
4716
4717 /* Do a smart match */
4718 PP(pp_smartmatch)
4719 {
4720     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4721     return do_smartmatch(NULL, NULL, 0);
4722 }
4723
4724 /* This version of do_smartmatch() implements the
4725  * table of smart matches that is found in perlsyn.
4726  */
4727 STATIC OP *
4728 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4729 {
4730     dSP;
4731
4732     bool object_on_left = FALSE;
4733     SV *e = TOPs;       /* e is for 'expression' */
4734     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4735
4736     /* Take care only to invoke mg_get() once for each argument.
4737      * Currently we do this by copying the SV if it's magical. */
4738     if (d) {
4739         if (!copied && SvGMAGICAL(d))
4740             d = sv_mortalcopy(d);
4741     }
4742     else
4743         d = &PL_sv_undef;
4744
4745     assert(e);
4746     if (SvGMAGICAL(e))
4747         e = sv_mortalcopy(e);
4748
4749     /* First of all, handle overload magic of the rightmost argument */
4750     if (SvAMAGIC(e)) {
4751         SV * tmpsv;
4752         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4753         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4754
4755         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4756         if (tmpsv) {
4757             SPAGAIN;
4758             (void)POPs;
4759             SETs(tmpsv);
4760             RETURN;
4761         }
4762         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4763     }
4764
4765     SP -= 2;    /* Pop the values */
4766     PUTBACK;
4767
4768     /* ~~ undef */
4769     if (!SvOK(e)) {
4770         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4771         if (SvOK(d))
4772             RETPUSHNO;
4773         else
4774             RETPUSHYES;
4775     }
4776
4777     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4778         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4779         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4780     }
4781     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4782         object_on_left = TRUE;
4783
4784     /* ~~ sub */
4785     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4786         I32 c;
4787         if (object_on_left) {
4788             goto sm_any_sub; /* Treat objects like scalars */
4789         }
4790         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4791             /* Test sub truth for each key */
4792             HE *he;
4793             bool andedresults = TRUE;
4794             HV *hv = (HV*) SvRV(d);
4795             I32 numkeys = hv_iterinit(hv);
4796             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4797             if (numkeys == 0)
4798                 RETPUSHYES;
4799             while ( (he = hv_iternext(hv)) ) {
4800                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4801                 ENTER_with_name("smartmatch_hash_key_test");
4802                 SAVETMPS;
4803                 PUSHMARK(SP);
4804                 PUSHs(hv_iterkeysv(he));
4805                 PUTBACK;
4806                 c = call_sv(e, G_SCALAR);
4807                 SPAGAIN;
4808                 if (c == 0)
4809                     andedresults = FALSE;
4810                 else
4811                     andedresults = SvTRUEx(POPs) && andedresults;
4812                 FREETMPS;
4813                 LEAVE_with_name("smartmatch_hash_key_test");
4814             }
4815             if (andedresults)
4816                 RETPUSHYES;
4817             else
4818                 RETPUSHNO;
4819         }
4820         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4821             /* Test sub truth for each element */
4822             SSize_t i;
4823             bool andedresults = TRUE;
4824             AV *av = (AV*) SvRV(d);
4825             const I32 len = av_tindex(av);
4826             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4827             if (len == -1)
4828                 RETPUSHYES;
4829             for (i = 0; i <= len; ++i) {
4830                 SV * const * const svp = av_fetch(av, i, FALSE);
4831                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4832                 ENTER_with_name("smartmatch_array_elem_test");
4833                 SAVETMPS;
4834                 PUSHMARK(SP);
4835                 if (svp)
4836                     PUSHs(*svp);
4837                 PUTBACK;
4838                 c = call_sv(e, G_SCALAR);
4839                 SPAGAIN;
4840                 if (c == 0)
4841                     andedresults = FALSE;
4842                 else
4843                     andedresults = SvTRUEx(POPs) && andedresults;
4844                 FREETMPS;
4845                 LEAVE_with_name("smartmatch_array_elem_test");
4846             }
4847             if (andedresults)
4848                 RETPUSHYES;
4849             else
4850                 RETPUSHNO;
4851         }
4852         else {
4853           sm_any_sub:
4854             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4855             ENTER_with_name("smartmatch_coderef");
4856             SAVETMPS;
4857             PUSHMARK(SP);
4858             PUSHs(d);
4859             PUTBACK;
4860             c = call_sv(e, G_SCALAR);
4861             SPAGAIN;
4862             if (c == 0)
4863                 PUSHs(&PL_sv_no);
4864             else if (SvTEMP(TOPs))
4865                 SvREFCNT_inc_void(TOPs);
4866             FREETMPS;
4867             LEAVE_with_name("smartmatch_coderef");
4868             RETURN;
4869         }
4870     }
4871     /* ~~ %hash */
4872     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4873         if (object_on_left) {
4874             goto sm_any_hash; /* Treat objects like scalars */
4875         }
4876         else if (!SvOK(d)) {
4877             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4878             RETPUSHNO;
4879         }
4880         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4881             /* Check that the key-sets are identical */
4882             HE *he;
4883             HV *other_hv = MUTABLE_HV(SvRV(d));
4884             bool tied;
4885             bool other_tied;
4886             U32 this_key_count  = 0,
4887                 other_key_count = 0;
4888             HV *hv = MUTABLE_HV(SvRV(e));
4889
4890             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4891             /* Tied hashes don't know how many keys they have. */
4892             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4893             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4894             if (!tied ) {
4895                 if(other_tied) {
4896                     /* swap HV sides */
4897                     HV * const temp = other_hv;
4898                     other_hv = hv;
4899                     hv = temp;
4900                     tied = TRUE;
4901                     other_tied = FALSE;
4902                 }
4903                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4904                     RETPUSHNO;
4905             }
4906
4907             /* The hashes have the same number of keys, so it suffices
4908                to check that one is a subset of the other. */
4909             (void) hv_iterinit(hv);
4910             while ( (he = hv_iternext(hv)) ) {
4911                 SV *key = hv_iterkeysv(he);
4912
4913                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4914                 ++ this_key_count;
4915
4916                 if(!hv_exists_ent(other_hv, key, 0)) {
4917                     (void) hv_iterinit(hv);     /* reset iterator */
4918                     RETPUSHNO;
4919                 }
4920             }
4921
4922             if (other_tied) {
4923                 (void) hv_iterinit(other_hv);
4924                 while ( hv_iternext(other_hv) )
4925                     ++other_key_count;
4926             }
4927             else
4928                 other_key_count = HvUSEDKEYS(other_hv);
4929
4930             if (this_key_count != other_key_count)
4931                 RETPUSHNO;
4932             else
4933                 RETPUSHYES;
4934         }
4935         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4936             AV * const other_av = MUTABLE_AV(SvRV(d));
4937             const SSize_t other_len = av_tindex(other_av) + 1;
4938             SSize_t i;
4939             HV *hv = MUTABLE_HV(SvRV(e));
4940
4941             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4942             for (i = 0; i < other_len; ++i) {
4943                 SV ** const svp = av_fetch(other_av, i, FALSE);
4944                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4945                 if (svp) {      /* ??? When can this not happen? */
4946                     if (hv_exists_ent(hv, *svp, 0))
4947                         RETPUSHYES;
4948                 }
4949             }
4950             RETPUSHNO;
4951         }
4952         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4953             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4954           sm_regex_hash:
4955             {
4956                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4957                 HE *he;
4958                 HV *hv = MUTABLE_HV(SvRV(e));
4959
4960                 (void) hv_iterinit(hv);
4961                 while ( (he = hv_iternext(hv)) ) {
4962                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4963                     PUTBACK;
4964                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4965                         SPAGAIN;
4966                         (void) hv_iterinit(hv);
4967                         destroy_matcher(matcher);
4968                         RETPUSHYES;
4969                     }
4970                     SPAGAIN;
4971                 }
4972                 destroy_matcher(matcher);
4973                 RETPUSHNO;
4974             }
4975         }
4976         else {
4977           sm_any_hash:
4978             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4979             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4980                 RETPUSHYES;
4981             else
4982                 RETPUSHNO;
4983         }
4984     }
4985     /* ~~ @array */
4986     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4987         if (object_on_left) {
4988             goto sm_any_array; /* Treat objects like scalars */
4989         }
4990         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4991             AV * const other_av = MUTABLE_AV(SvRV(e));
4992             const SSize_t other_len = av_tindex(other_av) + 1;
4993             SSize_t i;
4994
4995             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4996             for (i = 0; i < other_len; ++i) {
4997                 SV ** const svp = av_fetch(other_av, i, FALSE);
4998
4999                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
5000                 if (svp) {      /* ??? When can this not happen? */
5001                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5002                         RETPUSHYES;
5003                 }
5004             }
5005             RETPUSHNO;
5006         }
5007         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5008             AV *other_av = MUTABLE_AV(SvRV(d));
5009             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
5010             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
5011                 RETPUSHNO;
5012             else {
5013                 SSize_t i;
5014                 const SSize_t other_len = av_tindex(other_av);
5015
5016                 if (NULL == seen_this) {
5017                     seen_this = newHV();
5018                     (void) sv_2mortal(MUTABLE_SV(seen_this));
5019                 }
5020                 if (NULL == seen_other) {
5021                     seen_other = newHV();
5022                     (void) sv_2mortal(MUTABLE_SV(seen_other));
5023                 }
5024                 for(i = 0; i <= other_len; ++i) {
5025                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5026                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5027
5028                     if (!this_elem || !other_elem) {
5029                         if ((this_elem && SvOK(*this_elem))
5030                                 || (other_elem && SvOK(*other_elem)))
5031                             RETPUSHNO;
5032                     }
5033                     else if (hv_exists_ent(seen_this,
5034                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5035                             hv_exists_ent(seen_other,
5036                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5037                     {
5038                         if (*this_elem != *other_elem)
5039                             RETPUSHNO;
5040                     }
5041                     else {
5042                         (void)hv_store_ent(seen_this,
5043                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5044                                 &PL_sv_undef, 0);
5045                         (void)hv_store_ent(seen_other,
5046                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5047                                 &PL_sv_undef, 0);
5048                         PUSHs(*other_elem);
5049                         PUSHs(*this_elem);
5050
5051                         PUTBACK;
5052                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
5053                         (void) do_smartmatch(seen_this, seen_other, 0);
5054                         SPAGAIN;
5055                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
5056
5057                         if (!SvTRUEx(POPs))
5058                             RETPUSHNO;
5059                     }
5060                 }
5061                 RETPUSHYES;
5062             }
5063         }
5064         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5065             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
5066           sm_regex_array:
5067             {
5068                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5069                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5070                 SSize_t i;
5071
5072                 for(i = 0; i <= this_len; ++i) {
5073                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5074                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
5075                     PUTBACK;
5076                     if (svp && matcher_matches_sv(matcher, *svp)) {
5077                         SPAGAIN;
5078                         destroy_matcher(matcher);
5079                         RETPUSHYES;
5080                     }
5081                     SPAGAIN;
5082                 }
5083                 destroy_matcher(matcher);
5084                 RETPUSHNO;
5085             }
5086         }
5087         else if (!SvOK(d)) {
5088             /* undef ~~ array */
5089             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5090             SSize_t i;
5091
5092             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
5093             for (i = 0; i <= this_len; ++i) {
5094                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5095                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
5096                 if (!svp || !SvOK(*svp))
5097                     RETPUSHYES;
5098             }
5099             RETPUSHNO;
5100         }
5101         else {
5102           sm_any_array:
5103             {
5104                 SSize_t i;
5105                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5106
5107                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
5108                 for (i = 0; i <= this_len; ++i) {
5109                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5110                     if (!svp)
5111                         continue;
5112
5113                     PUSHs(d);
5114                     PUSHs(*svp);
5115                     PUTBACK;
5116                     /* infinite recursion isn't supposed to happen here */
5117                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
5118                     (void) do_smartmatch(NULL, NULL, 1);
5119                     SPAGAIN;
5120                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
5121                     if (SvTRUEx(POPs))
5122                         RETPUSHYES;
5123                 }
5124                 RETPUSHNO;
5125             }
5126         }
5127     }
5128     /* ~~ qr// */
5129     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5130         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5131             SV *t = d; d = e; e = t;
5132             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
5133             goto sm_regex_hash;
5134         }
5135         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5136             SV *t = d; d = e; e = t;
5137             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
5138             goto sm_regex_array;
5139         }
5140         else {
5141             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5142             bool result;
5143
5144             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
5145             PUTBACK;
5146             result = matcher_matches_sv(matcher, d);
5147             SPAGAIN;
5148             PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5149             destroy_matcher(matcher);
5150             RETURN;
5151         }
5152     }
5153     /* ~~ scalar */
5154     /* See if there is overload magic on left */
5155     else if (object_on_left && SvAMAGIC(d)) {
5156         SV *tmpsv;
5157         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
5158         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
5159         PUSHs(d); PUSHs(e);
5160         PUTBACK;
5161         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5162         if (tmpsv) {
5163             SPAGAIN;
5164             (void)POPs;
5165             SETs(tmpsv);
5166             RETURN;
5167         }
5168         SP -= 2;
5169         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
5170         goto sm_any_scalar;
5171     }
5172     else if (!SvOK(d)) {
5173         /* undef ~~ scalar ; we already know that the scalar is SvOK */
5174         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
5175         RETPUSHNO;
5176     }
5177     else
5178   sm_any_scalar:
5179     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5180         DEBUG_M(if (SvNIOK(e))
5181                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
5182                 else
5183                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
5184         );
5185         /* numeric comparison */
5186         PUSHs(d); PUSHs(e);
5187         PUTBACK;
5188         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5189             (void) Perl_pp_i_eq(aTHX);
5190         else
5191             (void) Perl_pp_eq(aTHX);
5192         SPAGAIN;
5193         if (SvTRUEx(POPs))
5194             RETPUSHYES;
5195         else
5196             RETPUSHNO;
5197     }
5198
5199     /* As a last resort, use string comparison */
5200     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
5201     PUSHs(d); PUSHs(e);
5202     PUTBACK;
5203     return Perl_pp_seq(aTHX);
5204 }
5205
5206 PP(pp_enterwhen)
5207 {
5208     dSP;
5209     PERL_CONTEXT *cx;
5210     const U8 gimme = GIMME_V;
5211
5212     /* This is essentially an optimization: if the match
5213        fails, we don't want to push a context and then
5214        pop it again right away, so we skip straight
5215        to the op that follows the leavewhen.
5216        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5217     */
5218     if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5219         if (gimme == G_SCALAR)
5220             PUSHs(&PL_sv_undef);
5221         RETURNOP(cLOGOP->op_other->op_next);
5222     }
5223
5224     cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5225     cx_pushwhen(cx);
5226
5227     RETURN;
5228 }
5229
5230 PP(pp_leavewhen)
5231 {
5232     I32 cxix;
5233     PERL_CONTEXT *cx;
5234     U8 gimme;
5235     SV **oldsp;
5236
5237     cx = CX_CUR();
5238     assert(CxTYPE(cx) == CXt_WHEN);
5239     gimme = cx->blk_gimme;
5240
5241     cxix = dopoptogivenfor(cxstack_ix);
5242     if (cxix < 0)
5243         /* diag_listed_as: Can't "when" outside a topicalizer */
5244         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5245                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5246
5247     oldsp = PL_stack_base + cx->blk_oldsp;
5248     if (gimme == G_VOID)
5249         PL_stack_sp = oldsp;
5250     else
5251         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5252
5253     /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5254     assert(cxix < cxstack_ix);
5255     dounwind(cxix);
5256
5257     cx = &cxstack[cxix];
5258
5259     if (CxFOREACH(cx)) {
5260         /* emulate pp_next. Note that any stack(s) cleanup will be
5261          * done by the pp_unstack which op_nextop should point to */
5262         cx = CX_CUR();
5263         cx_topblock(cx);
5264         PL_curcop = cx->blk_oldcop;
5265         return cx->blk_loop.my_op->op_nextop;
5266     }
5267     else {
5268         PERL_ASYNC_CHECK();
5269         assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5270         return cx->blk_givwhen.leave_op;
5271     }
5272 }
5273
5274 PP(pp_continue)
5275 {
5276     I32 cxix;
5277     PERL_CONTEXT *cx;
5278     OP *nextop;
5279
5280     cxix = dopoptowhen(cxstack_ix);
5281     if (cxix < 0)
5282         DIE(aTHX_ "Can't \"continue\" outside a when block");
5283
5284     if (cxix < cxstack_ix)
5285         dounwind(cxix);
5286
5287     cx = CX_CUR();
5288     assert(CxTYPE(cx) == CXt_WHEN);
5289     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5290     CX_LEAVE_SCOPE(cx);
5291     cx_popwhen(cx);
5292     cx_popblock(cx);
5293     nextop = cx->blk_givwhen.leave_op->op_next;
5294     CX_POP(cx);
5295
5296     return nextop;
5297 }
5298
5299 PP(pp_break)
5300 {
5301     I32 cxix;
5302     PERL_CONTEXT *cx;
5303
5304     cxix = dopoptogivenfor(cxstack_ix);
5305     if (cxix < 0)
5306         DIE(aTHX_ "Can't \"break\" outside a given block");
5307
5308     cx = &cxstack[cxix];
5309     if (CxFOREACH(cx))
5310         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5311
5312     if (cxix < cxstack_ix)
5313         dounwind(cxix);
5314
5315     /* Restore the sp at the time we entered the given block */
5316     cx = CX_CUR();
5317     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5318
5319     return cx->blk_givwhen.leave_op;
5320 }
5321
5322 static MAGIC *
5323 S_doparseform(pTHX_ SV *sv)
5324 {
5325     STRLEN len;
5326     char *s = SvPV(sv, len);
5327     char *send;
5328     char *base = NULL; /* start of current field */
5329     I32 skipspaces = 0; /* number of contiguous spaces seen */
5330     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5331     bool repeat    = FALSE; /* ~~ seen on this line */
5332     bool postspace = FALSE; /* a text field may need right padding */
5333     U32 *fops;
5334     U32 *fpc;
5335     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5336     I32 arg;
5337     bool ischop;            /* it's a ^ rather than a @ */
5338     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5339     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5340     MAGIC *mg = NULL;
5341     SV *sv_copy;
5342
5343     PERL_ARGS_ASSERT_DOPARSEFORM;
5344
5345     if (len == 0)
5346         Perl_croak(aTHX_ "Null picture in formline");
5347
5348     if (SvTYPE(sv) >= SVt_PVMG) {
5349         /* This might, of course, still return NULL.  */
5350         mg = mg_find(sv, PERL_MAGIC_fm);
5351     } else {
5352         sv_upgrade(sv, SVt_PVMG);
5353     }
5354
5355     if (mg) {
5356         /* still the same as previously-compiled string? */
5357         SV *old = mg->mg_obj;
5358         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5359               && len == SvCUR(old)
5360               && strnEQ(SvPVX(old), s, len)
5361         ) {
5362             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5363             return mg;
5364         }
5365
5366         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5367         Safefree(mg->mg_ptr);
5368         mg->mg_ptr = NULL;
5369         SvREFCNT_dec(old);
5370         mg->mg_obj = NULL;
5371     }
5372     else {
5373         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5374         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5375     }
5376
5377     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5378     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5379     send = s + len;
5380
5381
5382     /* estimate the buffer size needed */
5383     for (base = s; s <= send; s++) {
5384         if (*s == '\n' || *s == '@' || *s == '^')
5385             maxops += 10;
5386     }
5387     s = base;
5388     base = NULL;
5389
5390     Newx(fops, maxops, U32);
5391     fpc = fops;
5392
5393     if (s < send) {
5394         linepc = fpc;
5395         *fpc++ = FF_LINEMARK;
5396         noblank = repeat = FALSE;
5397         base = s;
5398     }
5399
5400     while (s <= send) {
5401         switch (*s++) {
5402         default:
5403             skipspaces = 0;
5404             continue;
5405
5406         case '~':
5407             if (*s == '~') {
5408                 repeat = TRUE;
5409                 skipspaces++;
5410                 s++;
5411             }
5412             noblank = TRUE;
5413             /* FALLTHROUGH */
5414         case ' ': case '\t':
5415             skipspaces++;
5416             continue;
5417         case 0:
5418             if (s < send) {
5419                 skipspaces = 0;
5420                 continue;
5421             }
5422             /* FALLTHROUGH */
5423         case '\n':
5424             arg = s - base;
5425             skipspaces++;
5426             arg -= skipspaces;
5427             if (arg) {
5428                 if (postspace)
5429                     *fpc++ = FF_SPACE;
5430                 *fpc++ = FF_LITERAL;
5431                 *fpc++ = (U32)arg;
5432             }
5433             postspace = FALSE;
5434             if (s <= send)
5435                 skipspaces--;
5436             if (skipspaces) {
5437                 *fpc++ = FF_SKIP;
5438                 *fpc++ = (U32)skipspaces;
5439             }
5440             skipspaces = 0;
5441             if (s <= send)
5442                 *fpc++ = FF_NEWLINE;
5443             if (noblank) {
5444                 *fpc++ = FF_BLANK;
5445                 if (repeat)
5446                     arg = fpc - linepc + 1;
5447                 else
5448                     arg = 0;
5449                 *fpc++ = (U32)arg;
5450             }
5451             if (s < send) {
5452                 linepc = fpc;
5453                 *fpc++ = FF_LINEMARK;
5454                 noblank = repeat = FALSE;
5455                 base = s;
5456             }
5457             else
5458                 s++;
5459             continue;
5460
5461         case '@':
5462         case '^':
5463             ischop = s[-1] == '^';
5464
5465             if (postspace) {
5466                 *fpc++ = FF_SPACE;
5467                 postspace = FALSE;
5468             }
5469             arg = (s - base) - 1;
5470             if (arg) {
5471                 *fpc++ = FF_LITERAL;
5472                 *fpc++ = (U32)arg;
5473             }
5474
5475             base = s - 1;
5476             *fpc++ = FF_FETCH;
5477             if (*s == '*') { /*  @* or ^*  */
5478                 s++;
5479                 *fpc++ = 2;  /* skip the @* or ^* */
5480                 if (ischop) {
5481                     *fpc++ = FF_LINESNGL;
5482                     *fpc++ = FF_CHOP;
5483                 } else
5484                     *fpc++ = FF_LINEGLOB;
5485             }
5486             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5487                 arg = ischop ? FORM_NUM_BLANK : 0;
5488                 base = s - 1;
5489                 while (*s == '#')
5490                     s++;
5491                 if (*s == '.') {
5492                     const char * const f = ++s;
5493                     while (*s == '#')
5494                         s++;
5495                     arg |= FORM_NUM_POINT + (s - f);
5496                 }
5497                 *fpc++ = s - base;              /* fieldsize for FETCH */
5498                 *fpc++ = FF_DECIMAL;
5499                 *fpc++ = (U32)arg;
5500                 unchopnum |= ! ischop;
5501             }
5502             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5503                 arg = ischop ? FORM_NUM_BLANK : 0;
5504                 base = s - 1;
5505                 s++;                                /* skip the '0' first */
5506                 while (*s == '#')
5507                     s++;
5508                 if (*s == '.') {
5509                     const char * const f = ++s;
5510                     while (*s == '#')
5511                         s++;
5512                     arg |= FORM_NUM_POINT + (s - f);
5513                 }
5514                 *fpc++ = s - base;                /* fieldsize for FETCH */
5515                 *fpc++ = FF_0DECIMAL;
5516                 *fpc++ = (U32)arg;
5517                 unchopnum |= ! ischop;
5518             }
5519             else {                              /* text field */
5520                 I32 prespace = 0;
5521                 bool ismore = FALSE;
5522
5523                 if (*s == '>') {
5524                     while (*++s == '>') ;
5525                     prespace = FF_SPACE;
5526                 }
5527                 else if (*s == '|') {
5528                     while (*++s == '|') ;
5529                     prespace = FF_HALFSPACE;
5530                     postspace = TRUE;
5531                 }
5532                 else {
5533                     if (*s == '<')
5534                         while (*++s == '<') ;
5535                     postspace = TRUE;
5536                 }
5537                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5538                     s += 3;
5539                     ismore = TRUE;
5540                 }
5541                 *fpc++ = s - base;              /* fieldsize for FETCH */
5542
5543                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5544
5545                 if (prespace)
5546                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5547                 *fpc++ = FF_ITEM;
5548                 if (ismore)
5549                     *fpc++ = FF_MORE;
5550                 if (ischop)
5551                     *fpc++ = FF_CHOP;
5552             }
5553             base = s;
5554             skipspaces = 0;
5555             continue;
5556         }
5557     }
5558     *fpc++ = FF_END;
5559
5560     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5561     arg = fpc - fops;
5562
5563     mg->mg_ptr = (char *) fops;
5564     mg->mg_len = arg * sizeof(U32);
5565     mg->mg_obj = sv_copy;
5566     mg->mg_flags |= MGf_REFCOUNTED;
5567
5568     if (unchopnum && repeat)
5569         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5570
5571     return mg;
5572 }
5573
5574
5575 STATIC bool
5576 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5577 {
5578     /* Can value be printed in fldsize chars, using %*.*f ? */
5579     NV pwr = 1;
5580     NV eps = 0.5;
5581     bool res = FALSE;
5582     int intsize = fldsize - (value < 0 ? 1 : 0);
5583
5584     if (frcsize & FORM_NUM_POINT)
5585         intsize--;
5586     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5587     intsize -= frcsize;
5588
5589     while (intsize--) pwr *= 10.0;
5590     while (frcsize--) eps /= 10.0;
5591
5592     if( value >= 0 ){
5593         if (value + eps >= pwr)
5594             res = TRUE;
5595     } else {
5596         if (value - eps <= -pwr)
5597             res = TRUE;
5598     }
5599     return res;
5600 }
5601
5602 static I32
5603 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5604 {
5605     SV * const datasv = FILTER_DATA(idx);
5606     const int filter_has_file = IoLINES(datasv);
5607     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5608     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5609     int status = 0;
5610     SV *upstream;
5611     STRLEN got_len;
5612     char *got_p = NULL;
5613     char *prune_from = NULL;
5614     bool read_from_cache = FALSE;
5615     STRLEN umaxlen;
5616     SV *err = NULL;
5617
5618     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5619
5620     assert(maxlen >= 0);
5621     umaxlen = maxlen;
5622
5623     /* I was having segfault trouble under Linux 2.2.5 after a
5624        parse error occurred.  (Had to hack around it with a test
5625        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5626        not sure where the trouble is yet.  XXX */
5627
5628     {
5629         SV *const cache = datasv;
5630         if (SvOK(cache)) {
5631             STRLEN cache_len;
5632             const char *cache_p = SvPV(cache, cache_len);
5633             STRLEN take = 0;
5634
5635             if (umaxlen) {
5636                 /* Running in block mode and we have some cached data already.
5637                  */
5638                 if (cache_len >= umaxlen) {
5639                     /* In fact, so much data we don't even need to call
5640                        filter_read.  */
5641                     take = umaxlen;
5642                 }
5643             } else {
5644                 const char *const first_nl =
5645                     (const char *)memchr(cache_p, '\n', cache_len);
5646                 if (first_nl) {
5647                     take = first_nl + 1 - cache_p;
5648                 }
5649             }
5650             if (take) {
5651                 sv_catpvn(buf_sv, cache_p, take);
5652                 sv_chop(cache, cache_p + take);
5653                 /* Definitely not EOF  */
5654                 return 1;
5655             }
5656
5657             sv_catsv(buf_sv, cache);
5658             if (umaxlen) {
5659                 umaxlen -= cache_len;
5660             }
5661             SvOK_off(cache);
5662             read_from_cache = TRUE;
5663         }
5664     }
5665
5666     /* Filter API says that the filter appends to the contents of the buffer.
5667        Usually the buffer is "", so the details don't matter. But if it's not,
5668        then clearly what it contains is already filtered by this filter, so we
5669        don't want to pass it in a second time.
5670        I'm going to use a mortal in case the upstream filter croaks.  */
5671     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5672         ? sv_newmortal() : buf_sv;
5673     SvUPGRADE(upstream, SVt_PV);
5674
5675     if (filter_has_file) {
5676         status = FILTER_READ(idx+1, upstream, 0);
5677     }
5678
5679     if (filter_sub && status >= 0) {
5680         dSP;
5681         int count;
5682
5683         ENTER_with_name("call_filter_sub");
5684         SAVE_DEFSV;
5685         SAVETMPS;
5686         EXTEND(SP, 2);
5687
5688         DEFSV_set(upstream);
5689         PUSHMARK(SP);
5690         PUSHs(&PL_sv_zero);
5691         if (filter_state) {
5692             PUSHs(filter_state);
5693         }
5694         PUTBACK;
5695         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5696         SPAGAIN;
5697
5698         if (count > 0) {
5699             SV *out = POPs;
5700             SvGETMAGIC(out);
5701             if (SvOK(out)) {
5702                 status = SvIV(out);
5703             }
5704             else {
5705                 SV * const errsv = ERRSV;
5706                 if (SvTRUE_NN(errsv))
5707                     err = newSVsv(errsv);
5708             }
5709         }
5710
5711         PUTBACK;
5712         FREETMPS;
5713         LEAVE_with_name("call_filter_sub");
5714     }
5715
5716     if (SvGMAGICAL(upstream)) {
5717         mg_get(upstream);
5718         if (upstream == buf_sv) mg_free(buf_sv);
5719     }
5720     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5721     if(!err && SvOK(upstream)) {
5722         got_p = SvPV_nomg(upstream, got_len);
5723         if (umaxlen) {
5724             if (got_len > umaxlen) {
5725                 prune_from = got_p + umaxlen;
5726             }
5727         } else {
5728             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5729             if (first_nl && first_nl + 1 < got_p + got_len) {
5730                 /* There's a second line here... */
5731                 prune_from = first_nl + 1;
5732             }
5733         }
5734     }
5735     if (!err && prune_from) {
5736         /* Oh. Too long. Stuff some in our cache.  */
5737         STRLEN cached_len = got_p + got_len - prune_from;
5738         SV *const cache = datasv;
5739
5740         if (SvOK(cache)) {
5741             /* Cache should be empty.  */
5742             assert(!SvCUR(cache));
5743         }
5744
5745         sv_setpvn(cache, prune_from, cached_len);
5746         /* If you ask for block mode, you may well split UTF-8 characters.
5747            "If it breaks, you get to keep both parts"
5748            (Your code is broken if you  don't put them back together again
5749            before something notices.) */
5750         if (SvUTF8(upstream)) {
5751             SvUTF8_on(cache);
5752         }
5753         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5754         else
5755             /* Cannot just use sv_setpvn, as that could free the buffer
5756                before we have a chance to assign it. */
5757             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5758                       got_len - cached_len);
5759         *prune_from = 0;
5760         /* Can't yet be EOF  */
5761         if (status == 0)
5762             status = 1;
5763     }
5764
5765     /* If they are at EOF but buf_sv has something in it, then they may never
5766        have touched the SV upstream, so it may be undefined.  If we naively
5767        concatenate it then we get a warning about use of uninitialised value.
5768     */
5769     if (!err && upstream != buf_sv &&
5770         SvOK(upstream)) {
5771         sv_catsv_nomg(buf_sv, upstream);
5772     }
5773     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5774
5775     if (status <= 0) {
5776         IoLINES(datasv) = 0;
5777         if (filter_state) {
5778             SvREFCNT_dec(filter_state);
5779             IoTOP_GV(datasv) = NULL;
5780         }
5781         if (filter_sub) {
5782             SvREFCNT_dec(filter_sub);
5783             IoBOTTOM_GV(datasv) = NULL;
5784         }
5785         filter_del(S_run_user_filter);
5786     }
5787
5788     if (err)
5789         croak_sv(err);
5790
5791     if (status == 0 && read_from_cache) {
5792         /* If we read some data from the cache (and by getting here it implies
5793            that we emptied the cache) then we aren't yet at EOF, and mustn't
5794            report that to our caller.  */
5795         return 1;
5796     }
5797     return status;
5798 }
5799
5800 /*
5801  * ex: set ts=8 sts=4 sw=4 et:
5802  */