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