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