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