pp_ctl.c

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