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