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