pp_ctl.c

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