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