pp_ctl.c

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