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             break;
1523         case CXt_LOOP_LAZYIV:
1524         case CXt_LOOP_LAZYSV:
1525         case CXt_LOOP_FOR:
1526         case CXt_LOOP_PLAIN:
1527             POPLOOP(cx);
1528             break;
1529         case CXt_NULL:
1530             break;
1531         case CXt_FORMAT:
1532             POPFORMAT(cx);
1533             break;
1534         }
1535         cxstack_ix--;
1536     }
1537     PERL_UNUSED_VAR(optype);
1538 }
1539
1540 void
1541 Perl_qerror(pTHX_ SV *err)
1542 {
1543     PERL_ARGS_ASSERT_QERROR;
1544
1545     if (PL_in_eval) {
1546         if (PL_in_eval & EVAL_KEEPERR) {
1547                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1548                                                     SVfARG(err));
1549         }
1550         else
1551             sv_catsv(ERRSV, err);
1552     }
1553     else if (PL_errors)
1554         sv_catsv(PL_errors, err);
1555     else
1556         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1557     if (PL_parser)
1558         ++PL_parser->error_count;
1559 }
1560
1561 void
1562 Perl_die_unwind(pTHX_ SV *msv)
1563 {
1564     SV *exceptsv = sv_mortalcopy(msv);
1565     U8 in_eval = PL_in_eval;
1566     PERL_ARGS_ASSERT_DIE_UNWIND;
1567
1568     if (in_eval) {
1569         I32 cxix;
1570         I32 gimme;
1571
1572         /*
1573          * Historically, perl used to set ERRSV ($@) early in the die
1574          * process and rely on it not getting clobbered during unwinding.
1575          * That sucked, because it was liable to get clobbered, so the
1576          * setting of ERRSV used to emit the exception from eval{} has
1577          * been moved to much later, after unwinding (see just before
1578          * JMPENV_JUMP below).  However, some modules were relying on the
1579          * early setting, by examining $@ during unwinding to use it as
1580          * a flag indicating whether the current unwinding was caused by
1581          * an exception.  It was never a reliable flag for that purpose,
1582          * being totally open to false positives even without actual
1583          * clobberage, but was useful enough for production code to
1584          * semantically rely on it.
1585          *
1586          * We'd like to have a proper introspective interface that
1587          * explicitly describes the reason for whatever unwinding
1588          * operations are currently in progress, so that those modules
1589          * work reliably and $@ isn't further overloaded.  But we don't
1590          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1591          * now *additionally* set here, before unwinding, to serve as the
1592          * (unreliable) flag that it used to.
1593          *
1594          * This behaviour is temporary, and should be removed when a
1595          * proper way to detect exceptional unwinding has been developed.
1596          * As of 2010-12, the authors of modules relying on the hack
1597          * are aware of the issue, because the modules failed on
1598          * perls 5.13.{1..7} which had late setting of $@ without this
1599          * early-setting hack.
1600          */
1601         if (!(in_eval & EVAL_KEEPERR)) {
1602             SvTEMP_off(exceptsv);
1603             sv_setsv(ERRSV, exceptsv);
1604         }
1605
1606         if (in_eval & EVAL_KEEPERR) {
1607             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1608                            SVfARG(exceptsv));
1609         }
1610
1611         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1612                && PL_curstackinfo->si_prev)
1613         {
1614             dounwind(-1);
1615             POPSTACK;
1616         }
1617
1618         if (cxix >= 0) {
1619             I32 optype;
1620             SV *namesv;
1621             PERL_CONTEXT *cx;
1622             SV **newsp;
1623 #ifdef DEBUGGING
1624             COP *oldcop;
1625 #endif
1626             JMPENV *restartjmpenv;
1627             OP *restartop;
1628
1629             if (cxix < cxstack_ix)
1630                 dounwind(cxix);
1631
1632             POPBLOCK(cx,PL_curpm);
1633             if (CxTYPE(cx) != CXt_EVAL) {
1634                 STRLEN msglen;
1635                 const char* message = SvPVx_const(exceptsv, msglen);
1636                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1637                 PerlIO_write(Perl_error_log, message, msglen);
1638                 my_exit(1);
1639             }
1640             POPEVAL(cx);
1641             namesv = cx->blk_eval.old_namesv;
1642 #ifdef DEBUGGING
1643             oldcop = cx->blk_oldcop;
1644 #endif
1645             restartjmpenv = cx->blk_eval.cur_top_env;
1646             restartop = cx->blk_eval.retop;
1647
1648             if (gimme == G_SCALAR)
1649                 *++newsp = &PL_sv_undef;
1650             PL_stack_sp = newsp;
1651
1652             LEAVE;
1653
1654             if (optype == OP_REQUIRE) {
1655                 assert (PL_curcop == oldcop);
1656                 (void)hv_store(GvHVn(PL_incgv),
1657                                SvPVX_const(namesv),
1658                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1659                                &PL_sv_undef, 0);
1660                 /* note that unlike pp_entereval, pp_require isn't
1661                  * supposed to trap errors. So now that we've popped the
1662                  * EVAL that pp_require pushed, and processed the error
1663                  * message, rethrow the error */
1664                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1665                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1666                                                                     SVs_TEMP)));
1667             }
1668             if (!(in_eval & EVAL_KEEPERR))
1669                 sv_setsv(ERRSV, exceptsv);
1670             PL_restartjmpenv = restartjmpenv;
1671             PL_restartop = restartop;
1672             JMPENV_JUMP(3);
1673             NOT_REACHED; /* NOTREACHED */
1674         }
1675     }
1676
1677     write_to_stderr(exceptsv);
1678     my_failure_exit();
1679     NOT_REACHED; /* NOTREACHED */
1680 }
1681
1682 PP(pp_xor)
1683 {
1684     dSP; dPOPTOPssrl;
1685     if (SvTRUE(left) != SvTRUE(right))
1686         RETSETYES;
1687     else
1688         RETSETNO;
1689 }
1690
1691 /*
1692
1693 =head1 CV Manipulation Functions
1694
1695 =for apidoc caller_cx
1696
1697 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1698 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1699 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1700 stack frame, so C<caller_cx(0, NULL)> will return information for the
1701 immediately-surrounding Perl code.
1702
1703 This function skips over the automatic calls to C<&DB::sub> made on the
1704 behalf of the debugger.  If the stack frame requested was a sub called by
1705 C<DB::sub>, the return value will be the frame for the call to
1706 C<DB::sub>, since that has the correct line number/etc. for the call
1707 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1708 frame for the sub call itself.
1709
1710 =cut
1711 */
1712
1713 const PERL_CONTEXT *
1714 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1715 {
1716     I32 cxix = dopoptosub(cxstack_ix);
1717     const PERL_CONTEXT *cx;
1718     const PERL_CONTEXT *ccstack = cxstack;
1719     const PERL_SI *top_si = PL_curstackinfo;
1720
1721     for (;;) {
1722         /* we may be in a higher stacklevel, so dig down deeper */
1723         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1724             top_si = top_si->si_prev;
1725             ccstack = top_si->si_cxstack;
1726             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1727         }
1728         if (cxix < 0)
1729             return NULL;
1730         /* caller() should not report the automatic calls to &DB::sub */
1731         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1732                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1733             count++;
1734         if (!count--)
1735             break;
1736         cxix = dopoptosub_at(ccstack, cxix - 1);
1737     }
1738
1739     cx = &ccstack[cxix];
1740     if (dbcxp) *dbcxp = cx;
1741
1742     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1743         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1744         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1745            field below is defined for any cx. */
1746         /* caller() should not report the automatic calls to &DB::sub */
1747         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1748             cx = &ccstack[dbcxix];
1749     }
1750
1751     return cx;
1752 }
1753
1754 PP(pp_caller)
1755 {
1756     dSP;
1757     const PERL_CONTEXT *cx;
1758     const PERL_CONTEXT *dbcx;
1759     I32 gimme = GIMME_V;
1760     const HEK *stash_hek;
1761     I32 count = 0;
1762     bool has_arg = MAXARG && TOPs;
1763     const COP *lcop;
1764
1765     if (MAXARG) {
1766       if (has_arg)
1767         count = POPi;
1768       else (void)POPs;
1769     }
1770
1771     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1772     if (!cx) {
1773         if (gimme != G_ARRAY) {
1774             EXTEND(SP, 1);
1775             RETPUSHUNDEF;
1776         }
1777         RETURN;
1778     }
1779
1780     DEBUG_CX("CALLER");
1781     assert(CopSTASH(cx->blk_oldcop));
1782     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1783       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1784       : NULL;
1785     if (gimme != G_ARRAY) {
1786         EXTEND(SP, 1);
1787         if (!stash_hek)
1788             PUSHs(&PL_sv_undef);
1789         else {
1790             dTARGET;
1791             sv_sethek(TARG, stash_hek);
1792             PUSHs(TARG);
1793         }
1794         RETURN;
1795     }
1796
1797     EXTEND(SP, 11);
1798
1799     if (!stash_hek)
1800         PUSHs(&PL_sv_undef);
1801     else {
1802         dTARGET;
1803         sv_sethek(TARG, stash_hek);
1804         PUSHTARG;
1805     }
1806     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1807     lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1808                        cx->blk_sub.retop, TRUE);
1809     if (!lcop)
1810         lcop = cx->blk_oldcop;
1811     mPUSHu(CopLINE(lcop));
1812     if (!has_arg)
1813         RETURN;
1814     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1815         /* So is ccstack[dbcxix]. */
1816         if (CvHASGV(dbcx->blk_sub.cv)) {
1817             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1818             PUSHs(boolSV(CxHASARGS(cx)));
1819         }
1820         else {
1821             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1822             PUSHs(boolSV(CxHASARGS(cx)));
1823         }
1824     }
1825     else {
1826         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1827         mPUSHi(0);
1828     }
1829     gimme = (I32)cx->blk_gimme;
1830     if (gimme == G_VOID)
1831         PUSHs(&PL_sv_undef);
1832     else
1833         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1834     if (CxTYPE(cx) == CXt_EVAL) {
1835         /* eval STRING */
1836         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1837             SV *cur_text = cx->blk_eval.cur_text;
1838             if (SvCUR(cur_text) >= 2) {
1839                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1840                                      SvUTF8(cur_text)|SVs_TEMP));
1841             }
1842             else {
1843                 /* I think this is will always be "", but be sure */
1844                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1845             }
1846
1847             PUSHs(&PL_sv_no);
1848         }
1849         /* require */
1850         else if (cx->blk_eval.old_namesv) {
1851             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1852             PUSHs(&PL_sv_yes);
1853         }
1854         /* eval BLOCK (try blocks have old_namesv == 0) */
1855         else {
1856             PUSHs(&PL_sv_undef);
1857             PUSHs(&PL_sv_undef);
1858         }
1859     }
1860     else {
1861         PUSHs(&PL_sv_undef);
1862         PUSHs(&PL_sv_undef);
1863     }
1864     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1865         && CopSTASH_eq(PL_curcop, PL_debstash))
1866     {
1867         AV * const ary = cx->blk_sub.argarray;
1868         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1869
1870         Perl_init_dbargs(aTHX);
1871
1872         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1873             av_extend(PL_dbargs, AvFILLp(ary) + off);
1874         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1875         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1876     }
1877     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1878     {
1879         SV * mask ;
1880         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1881
1882         if  (old_warnings == pWARN_NONE)
1883             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1884         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1885             mask = &PL_sv_undef ;
1886         else if (old_warnings == pWARN_ALL ||
1887                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1888             /* Get the bit mask for $warnings::Bits{all}, because
1889              * it could have been extended by warnings::register */
1890             SV **bits_all;
1891             HV * const bits = get_hv("warnings::Bits", 0);
1892             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1893                 mask = newSVsv(*bits_all);
1894             }
1895             else {
1896                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1897             }
1898         }
1899         else
1900             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1901         mPUSHs(mask);
1902     }
1903
1904     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1905           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1906           : &PL_sv_undef);
1907     RETURN;
1908 }
1909
1910 PP(pp_reset)
1911 {
1912     dSP;
1913     const char * tmps;
1914     STRLEN len = 0;
1915     if (MAXARG < 1 || (!TOPs && !POPs))
1916         tmps = NULL, len = 0;
1917     else
1918         tmps = SvPVx_const(POPs, len);
1919     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1920     PUSHs(&PL_sv_yes);
1921     RETURN;
1922 }
1923
1924 /* like pp_nextstate, but used instead when the debugger is active */
1925
1926 PP(pp_dbstate)
1927 {
1928     PL_curcop = (COP*)PL_op;
1929     TAINT_NOT;          /* Each statement is presumed innocent */
1930     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1931     FREETMPS;
1932
1933     PERL_ASYNC_CHECK();
1934
1935     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1936             || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1937     {
1938         dSP;
1939         PERL_CONTEXT *cx;
1940         const I32 gimme = G_ARRAY;
1941         U8 hasargs;
1942         GV * const gv = PL_DBgv;
1943         CV * cv = NULL;
1944
1945         if (gv && isGV_with_GP(gv))
1946             cv = GvCV(gv);
1947
1948         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1949             DIE(aTHX_ "No DB::DB routine defined");
1950
1951         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1952             /* don't do recursive DB::DB call */
1953             return NORMAL;
1954
1955         ENTER;
1956         SAVETMPS;
1957
1958         SAVEI32(PL_debug);
1959         SAVESTACK_POS();
1960         PL_debug = 0;
1961         hasargs = 0;
1962         SPAGAIN;
1963
1964         if (CvISXSUB(cv)) {
1965             PUSHMARK(SP);
1966             (void)(*CvXSUB(cv))(aTHX_ cv);
1967             FREETMPS;
1968             LEAVE;
1969             return NORMAL;
1970         }
1971         else {
1972             PUSHBLOCK(cx, CXt_SUB, SP);
1973             PUSHSUB_DB(cx);
1974             cx->blk_sub.retop = PL_op->op_next;
1975             CvDEPTH(cv)++;
1976             if (CvDEPTH(cv) >= 2) {
1977                 PERL_STACK_OVERFLOW_CHECK();
1978                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1979             }
1980             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1981             RETURNOP(CvSTART(cv));
1982         }
1983     }
1984     else
1985         return NORMAL;
1986 }
1987
1988 /* S_leave_common: Common code that many functions in this file use on
1989                    scope exit.  */
1990
1991 /* SVs on the stack that have any of the flags passed in are left as is.
1992    Other SVs are protected via the mortals stack if lvalue is true, and
1993    copied otherwise.
1994
1995    Also, taintedness is cleared.
1996 */
1997
1998 STATIC SV **
1999 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2000                               U32 flags, bool lvalue)
2001 {
2002     bool padtmp = 0;
2003     PERL_ARGS_ASSERT_LEAVE_COMMON;
2004
2005     TAINT_NOT;
2006     if (flags & SVs_PADTMP) {
2007         flags &= ~SVs_PADTMP;
2008         padtmp = 1;
2009     }
2010     if (gimme == G_SCALAR) {
2011         if (MARK < SP)
2012             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2013                             ? *SP
2014                             : lvalue
2015                                 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2016                                 : sv_mortalcopy(*SP);
2017         else {
2018             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2019             MARK = newsp;
2020             MEXTEND(MARK, 1);
2021             *++MARK = &PL_sv_undef;
2022             return MARK;
2023         }
2024     }
2025     else if (gimme == G_ARRAY) {
2026         /* in case LEAVE wipes old return values */
2027         while (++MARK <= SP) {
2028             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2029                 *++newsp = *MARK;
2030             else {
2031                 *++newsp = lvalue
2032                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2033                             : sv_mortalcopy(*MARK);
2034                 TAINT_NOT;      /* Each item is independent */
2035             }
2036         }
2037         /* When this function was called with MARK == newsp, we reach this
2038          * point with SP == newsp. */
2039     }
2040
2041     return newsp;
2042 }
2043
2044 PP(pp_enter)
2045 {
2046     dSP;
2047     PERL_CONTEXT *cx;
2048     I32 gimme = GIMME_V;
2049
2050     ENTER_with_name("block");
2051
2052     SAVETMPS;
2053     PUSHBLOCK(cx, CXt_BLOCK, SP);
2054
2055     RETURN;
2056 }
2057
2058 PP(pp_leave)
2059 {
2060     dSP;
2061     PERL_CONTEXT *cx;
2062     SV **newsp;
2063     PMOP *newpm;
2064     I32 gimme;
2065
2066     if (PL_op->op_flags & OPf_SPECIAL) {
2067         cx = &cxstack[cxstack_ix];
2068         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2069     }
2070
2071     POPBLOCK(cx,newpm);
2072
2073     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2074
2075     SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2076                                PL_op->op_private & OPpLVALUE);
2077     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2078
2079     LEAVE_with_name("block");
2080
2081     RETURN;
2082 }
2083
2084 static bool
2085 S_outside_integer(pTHX_ SV *sv)
2086 {
2087   if (SvOK(sv)) {
2088     const NV nv = SvNV_nomg(sv);
2089     if (Perl_isinfnan(nv))
2090       return TRUE;
2091 #ifdef NV_PRESERVES_UV
2092     if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2093       return TRUE;
2094 #else
2095     if (nv <= (NV)IV_MIN)
2096       return TRUE;
2097     if ((nv > 0) &&
2098         ((nv > (NV)UV_MAX ||
2099           SvUV_nomg(sv) > (UV)IV_MAX)))
2100       return TRUE;
2101 #endif
2102   }
2103   return FALSE;
2104 }
2105
2106 PP(pp_enteriter)
2107 {
2108     dSP; dMARK;
2109     PERL_CONTEXT *cx;
2110     const I32 gimme = GIMME_V;
2111     void *itervar; /* location of the iteration variable */
2112     U8 cxtype = CXt_LOOP_FOR;
2113
2114     ENTER_with_name("loop1");
2115     SAVETMPS;
2116
2117     if (PL_op->op_targ) {                        /* "my" variable */
2118         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2119             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2120             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2121                     SVs_PADSTALE, SVs_PADSTALE);
2122         }
2123         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2124 #ifdef USE_ITHREADS
2125         itervar = PL_comppad;
2126 #else
2127         itervar = &PAD_SVl(PL_op->op_targ);
2128 #endif
2129     }
2130     else if (LIKELY(isGV(TOPs))) {              /* symbol table variable */
2131         GV * const gv = MUTABLE_GV(POPs);
2132         SV** svp = &GvSV(gv);
2133         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2134         *svp = newSV(0);
2135         itervar = (void *)gv;
2136     }
2137     else {
2138         SV * const sv = POPs;
2139         assert(SvTYPE(sv) == SVt_PVMG);
2140         assert(SvMAGIC(sv));
2141         assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2142         itervar = (void *)sv;
2143         cxtype |= CXp_FOR_LVREF;
2144     }
2145
2146     if (PL_op->op_private & OPpITER_DEF)
2147         cxtype |= CXp_FOR_DEF;
2148
2149     ENTER_with_name("loop2");
2150
2151     PUSHBLOCK(cx, cxtype, SP);
2152     PUSHLOOP_FOR(cx, itervar, MARK);
2153     if (PL_op->op_flags & OPf_STACKED) {
2154         SV *maybe_ary = POPs;
2155         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2156             dPOPss;
2157             SV * const right = maybe_ary;
2158             if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2159                 DIE(aTHX_ "Assigned value is not a reference");
2160             SvGETMAGIC(sv);
2161             SvGETMAGIC(right);
2162             if (RANGE_IS_NUMERIC(sv,right)) {
2163                 cx->cx_type &= ~CXTYPEMASK;
2164                 cx->cx_type |= CXt_LOOP_LAZYIV;
2165                 /* Make sure that no-one re-orders cop.h and breaks our
2166                    assumptions */
2167                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2168                 if (S_outside_integer(aTHX_ sv) ||
2169                     S_outside_integer(aTHX_ right))
2170                     DIE(aTHX_ "Range iterator outside integer range");
2171                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2172                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2173 #ifdef DEBUGGING
2174                 /* for correct -Dstv display */
2175                 cx->blk_oldsp = sp - PL_stack_base;
2176 #endif
2177             }
2178             else {
2179                 cx->cx_type &= ~CXTYPEMASK;
2180                 cx->cx_type |= CXt_LOOP_LAZYSV;
2181                 /* Make sure that no-one re-orders cop.h and breaks our
2182                    assumptions */
2183                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2184                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2185                 cx->blk_loop.state_u.lazysv.end = right;
2186                 SvREFCNT_inc(right);
2187                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2188                 /* This will do the upgrade to SVt_PV, and warn if the value
2189                    is uninitialised.  */
2190                 (void) SvPV_nolen_const(right);
2191                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2192                    to replace !SvOK() with a pointer to "".  */
2193                 if (!SvOK(right)) {
2194                     SvREFCNT_dec(right);
2195                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2196                 }
2197             }
2198         }
2199         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2200             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2201             SvREFCNT_inc(maybe_ary);
2202             cx->blk_loop.state_u.ary.ix =
2203                 (PL_op->op_private & OPpITER_REVERSED) ?
2204                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2205                 -1;
2206         }
2207     }
2208     else { /* iterating over items on the stack */
2209         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2210         if (PL_op->op_private & OPpITER_REVERSED) {
2211             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2212         }
2213         else {
2214             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2215         }
2216     }
2217
2218     RETURN;
2219 }
2220
2221 PP(pp_enterloop)
2222 {
2223     dSP;
2224     PERL_CONTEXT *cx;
2225     const I32 gimme = GIMME_V;
2226
2227     ENTER_with_name("loop1");
2228     SAVETMPS;
2229     ENTER_with_name("loop2");
2230
2231     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2232     PUSHLOOP_PLAIN(cx, SP);
2233
2234     RETURN;
2235 }
2236
2237 PP(pp_leaveloop)
2238 {
2239     dSP;
2240     PERL_CONTEXT *cx;
2241     I32 gimme;
2242     SV **newsp;
2243     PMOP *newpm;
2244     SV **mark;
2245
2246     POPBLOCK(cx,newpm);
2247     assert(CxTYPE_is_LOOP(cx));
2248     mark = newsp;
2249     newsp = PL_stack_base + cx->blk_loop.resetsp;
2250
2251     SP = leave_common(newsp, SP, MARK, gimme, 0,
2252                                PL_op->op_private & OPpLVALUE);
2253     PUTBACK;
2254
2255     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2256     PL_curpm = newpm;   /* ... and pop $1 et al */
2257
2258     LEAVE_with_name("loop2");
2259     LEAVE_with_name("loop1");
2260
2261     return NORMAL;
2262 }
2263
2264
2265 /* This duplicates most of pp_leavesub, but with additional code to handle
2266  * return args in lvalue context. It was forked from pp_leavesub to
2267  * avoid slowing down that function any further.
2268  *
2269  * Any changes made to this function may need to be copied to pp_leavesub
2270  * and vice-versa.
2271  */
2272
2273 PP(pp_leavesublv)
2274 {
2275     dSP;
2276     SV **newsp;
2277     SV **mark;
2278     PMOP *newpm;
2279     I32 gimme;
2280     PERL_CONTEXT *cx;
2281     SV *sv;
2282     bool ref;
2283     const char *what = NULL;
2284
2285     if (CxMULTICALL(&cxstack[cxstack_ix])) {
2286         /* entry zero of a stack is always PL_sv_undef, which
2287          * simplifies converting a '()' return into undef in scalar context */
2288         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2289         return 0;
2290     }
2291
2292     POPBLOCK(cx,newpm);
2293     cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2294     TAINT_NOT;
2295
2296     mark = newsp + 1;
2297
2298     ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2299     if (gimme == G_SCALAR) {
2300         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2301             SV *sv;
2302             if (MARK <= SP) {
2303                 assert(MARK == SP);
2304                 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2305                     !SvSMAGICAL(TOPs)) {
2306                     what =
2307                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2308                         : "a readonly value" : "a temporary";
2309                 }
2310                 else goto copy_sv;
2311             }
2312             else {
2313                 /* sub:lvalue{} will take us here. */
2314                 what = "undef";
2315             }
2316           croak:
2317             LEAVE;
2318             POPSUB(cx,sv);
2319             cxstack_ix--;
2320             PL_curpm = newpm;
2321             LEAVESUB(sv);
2322             Perl_croak(aTHX_
2323                       "Can't return %s from lvalue subroutine", what
2324             );
2325         }
2326         if (MARK <= SP) {
2327               copy_sv:
2328                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2329                     if (!SvPADTMP(*SP)) {
2330                         *MARK = SvREFCNT_inc(*SP);
2331                         FREETMPS;
2332                         sv_2mortal(*MARK);
2333                     }
2334                     else {
2335                         /* FREETMPS could clobber it */
2336                         SV *sv = SvREFCNT_inc(*SP);
2337                         FREETMPS;
2338                         *MARK = sv_mortalcopy(sv);
2339                         SvREFCNT_dec(sv);
2340                     }
2341                 }
2342                 else
2343                     *MARK =
2344                       SvPADTMP(*SP)
2345                        ? sv_mortalcopy(*SP)
2346                        : !SvTEMP(*SP)
2347                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2348                           : *SP;
2349         }
2350         else {
2351             MEXTEND(MARK, 0);
2352             *MARK = &PL_sv_undef;
2353         }
2354         SP = MARK;
2355
2356         if (CxLVAL(cx) & OPpDEREF) {
2357             SvGETMAGIC(TOPs);
2358             if (!SvOK(TOPs)) {
2359                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2360             }
2361         }
2362     }
2363     else if (gimme == G_ARRAY) {
2364         assert (!(CxLVAL(cx) & OPpDEREF));
2365         if (ref || !CxLVAL(cx))
2366             for (; MARK <= SP; MARK++)
2367                 *MARK =
2368                        SvFLAGS(*MARK) & SVs_PADTMP
2369                            ? sv_mortalcopy(*MARK)
2370                      : SvTEMP(*MARK)
2371                            ? *MARK
2372                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2373         else for (; MARK <= SP; MARK++) {
2374             if (*MARK != &PL_sv_undef
2375                     && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2376             ) {
2377                     /* Might be flattened array after $#array =  */
2378                     what = SvREADONLY(*MARK)
2379                             ? "a readonly value" : "a temporary";
2380                     goto croak;
2381             }
2382             else if (!SvTEMP(*MARK))
2383                 *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2384         }
2385     }
2386     PUTBACK;
2387
2388     LEAVE;
2389     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2390     cxstack_ix--;
2391     PL_curpm = newpm;   /* ... and pop $1 et al */
2392     LEAVESUB(sv);
2393
2394     return cx->blk_sub.retop;
2395 }
2396
2397
2398 PP(pp_return)
2399 {
2400     dSP; dMARK;
2401     PERL_CONTEXT *cx;
2402     SV **oldsp;
2403     const I32 cxix = dopoptosub(cxstack_ix);
2404
2405     assert(cxstack_ix >= 0);
2406     if (cxix < cxstack_ix) {
2407         if (cxix < 0) {
2408             if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2409                                          * sort block, which is a CXt_NULL
2410                                          * not a CXt_SUB */
2411                 dounwind(0);
2412                 /* if we were in list context, we would have to splice out
2413                  * any junk before the return args, like we do in the general
2414                  * pp_return case, e.g.
2415                  *   sub f { for (junk1, junk2) { return arg1, arg2 }}
2416                  */
2417                 assert(cxstack[0].blk_gimme == G_SCALAR);
2418                 return 0;
2419             }
2420             else
2421                 DIE(aTHX_ "Can't return outside a subroutine");
2422         }
2423         dounwind(cxix);
2424     }
2425
2426     cx = &cxstack[cxix];
2427
2428     oldsp = PL_stack_base + cx->blk_oldsp;
2429     if (oldsp != MARK) {
2430         /* Handle extra junk on the stack. For example,
2431          *    for (1,2) { return 3,4 }
2432          * leaves 1,2,3,4 on the stack. In list context we
2433          * have to splice out the 1,2; In scalar context for
2434          *    for (1,2) { return }
2435          * we need to set sp = oldsp so that pp_leavesub knows
2436          * to push &PL_sv_undef onto the stack.
2437          * Note that in pp_return we only do the extra processing
2438          * required to handle junk; everything else we leave to
2439          * pp_leavesub.
2440          */
2441         SSize_t nargs = SP - MARK;
2442         if (nargs) {
2443             if (cx->blk_gimme == G_ARRAY) {
2444                 /* shift return args to base of call stack frame */
2445                 Move(MARK + 1, oldsp + 1, nargs, SV*);
2446                 PL_stack_sp  = oldsp + nargs;
2447             }
2448         }
2449         else
2450             PL_stack_sp  = oldsp;
2451     }
2452
2453     /* fall through to a normal exit */
2454     switch (CxTYPE(cx)) {
2455     case CXt_EVAL:
2456         return CxTRYBLOCK(cx)
2457             ? Perl_pp_leavetry(aTHX)
2458             : Perl_pp_leaveeval(aTHX);
2459     case CXt_SUB:
2460         return CvLVALUE(cx->blk_sub.cv)
2461             ? Perl_pp_leavesublv(aTHX)
2462             : Perl_pp_leavesub(aTHX);
2463     case CXt_FORMAT:
2464         return Perl_pp_leavewrite(aTHX);
2465     default:
2466         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2467     }
2468 }
2469
2470
2471 static I32
2472 S_unwind_loop(pTHX_ const char * const opname)
2473 {
2474     I32 cxix;
2475     if (PL_op->op_flags & OPf_SPECIAL) {
2476         cxix = dopoptoloop(cxstack_ix);
2477         if (cxix < 0)
2478             /* diag_listed_as: Can't "last" outside a loop block */
2479             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2480     }
2481     else {
2482         dSP;
2483         STRLEN label_len;
2484         const char * const label =
2485             PL_op->op_flags & OPf_STACKED
2486                 ? SvPV(TOPs,label_len)
2487                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2488         const U32 label_flags =
2489             PL_op->op_flags & OPf_STACKED
2490                 ? SvUTF8(POPs)
2491                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2492         PUTBACK;
2493         cxix = dopoptolabel(label, label_len, label_flags);
2494         if (cxix < 0)
2495             /* diag_listed_as: Label not found for "last %s" */
2496             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2497                                        opname,
2498                                        SVfARG(PL_op->op_flags & OPf_STACKED
2499                                               && !SvGMAGICAL(TOPp1s)
2500                                               ? TOPp1s
2501                                               : newSVpvn_flags(label,
2502                                                     label_len,
2503                                                     label_flags | SVs_TEMP)));
2504     }
2505     if (cxix < cxstack_ix)
2506         dounwind(cxix);
2507     return cxix;
2508 }
2509
2510 PP(pp_last)
2511 {
2512     PERL_CONTEXT *cx;
2513     I32 gimme;
2514     OP *nextop = NULL;
2515     SV **newsp;
2516     PMOP *newpm;
2517
2518     S_unwind_loop(aTHX_ "last");
2519
2520     POPBLOCK(cx,newpm);
2521     cxstack_ix++; /* temporarily protect top context */
2522     assert(
2523            CxTYPE(cx) == CXt_LOOP_LAZYIV
2524         || CxTYPE(cx) == CXt_LOOP_LAZYSV
2525         || CxTYPE(cx) == CXt_LOOP_FOR
2526         || CxTYPE(cx) == CXt_LOOP_PLAIN
2527     );
2528     newsp = PL_stack_base + cx->blk_loop.resetsp;
2529     nextop = cx->blk_loop.my_op->op_lastop->op_next;
2530
2531     TAINT_NOT;
2532     PL_stack_sp = newsp;
2533
2534     LEAVE;
2535     cxstack_ix--;
2536     /* Stack values are safe: */
2537     POPLOOP(cx);        /* release loop vars ... */
2538     LEAVE;
2539     PL_curpm = newpm;   /* ... and pop $1 et al */
2540
2541     PERL_UNUSED_VAR(gimme);
2542     return nextop;
2543 }
2544
2545 PP(pp_next)
2546 {
2547     PERL_CONTEXT *cx;
2548     const I32 inner = PL_scopestack_ix;
2549
2550     S_unwind_loop(aTHX_ "next");
2551
2552     /* clear off anything above the scope we're re-entering, but
2553      * save the rest until after a possible continue block */
2554     TOPBLOCK(cx);
2555     if (PL_scopestack_ix < inner)
2556         leave_scope(PL_scopestack[PL_scopestack_ix]);
2557     PL_curcop = cx->blk_oldcop;
2558     PERL_ASYNC_CHECK();
2559     return (cx)->blk_loop.my_op->op_nextop;
2560 }
2561
2562 PP(pp_redo)
2563 {
2564     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2565     PERL_CONTEXT *cx;
2566     I32 oldsave;
2567     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2568
2569     if (redo_op->op_type == OP_ENTER) {
2570         /* pop one less context to avoid $x being freed in while (my $x..) */
2571         cxstack_ix++;
2572         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2573         redo_op = redo_op->op_next;
2574     }
2575
2576     TOPBLOCK(cx);
2577     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2578     LEAVE_SCOPE(oldsave);
2579     FREETMPS;
2580     PL_curcop = cx->blk_oldcop;
2581     PERL_ASYNC_CHECK();
2582     return redo_op;
2583 }
2584
2585 STATIC OP *
2586 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2587 {
2588     OP **ops = opstack;
2589     static const char* const too_deep = "Target of goto is too deeply nested";
2590
2591     PERL_ARGS_ASSERT_DOFINDLABEL;
2592
2593     if (ops >= oplimit)
2594         Perl_croak(aTHX_ "%s", too_deep);
2595     if (o->op_type == OP_LEAVE ||
2596         o->op_type == OP_SCOPE ||
2597         o->op_type == OP_LEAVELOOP ||
2598         o->op_type == OP_LEAVESUB ||
2599         o->op_type == OP_LEAVETRY)
2600     {
2601         *ops++ = cUNOPo->op_first;
2602         if (ops >= oplimit)
2603             Perl_croak(aTHX_ "%s", too_deep);
2604     }
2605     *ops = 0;
2606     if (o->op_flags & OPf_KIDS) {
2607         OP *kid;
2608         /* First try all the kids at this level, since that's likeliest. */
2609         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2610             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2611                 STRLEN kid_label_len;
2612                 U32 kid_label_flags;
2613                 const char *kid_label = CopLABEL_len_flags(kCOP,
2614                                                     &kid_label_len, &kid_label_flags);
2615                 if (kid_label && (
2616                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2617                         (flags & SVf_UTF8)
2618                             ? (bytes_cmp_utf8(
2619                                         (const U8*)kid_label, kid_label_len,
2620                                         (const U8*)label, len) == 0)
2621                             : (bytes_cmp_utf8(
2622                                         (const U8*)label, len,
2623                                         (const U8*)kid_label, kid_label_len) == 0)
2624                     : ( len == kid_label_len && ((kid_label == label)
2625                                     || memEQ(kid_label, label, len)))))
2626                     return kid;
2627             }
2628         }
2629         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2630             if (kid == PL_lastgotoprobe)
2631                 continue;
2632             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2633                 if (ops == opstack)
2634                     *ops++ = kid;
2635                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2636                          ops[-1]->op_type == OP_DBSTATE)
2637                     ops[-1] = kid;
2638                 else
2639                     *ops++ = kid;
2640             }
2641             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2642                 return o;
2643         }
2644     }
2645     *ops = 0;
2646     return 0;
2647 }
2648
2649
2650 /* also used for: pp_dump() */
2651
2652 PP(pp_goto)
2653 {
2654     dVAR; dSP;
2655     OP *retop = NULL;
2656     I32 ix;
2657     PERL_CONTEXT *cx;
2658 #define GOTO_DEPTH 64
2659     OP *enterops[GOTO_DEPTH];
2660     const char *label = NULL;
2661     STRLEN label_len = 0;
2662     U32 label_flags = 0;
2663     const bool do_dump = (PL_op->op_type == OP_DUMP);
2664     static const char* const must_have_label = "goto must have label";
2665
2666     if (PL_op->op_flags & OPf_STACKED) {
2667         /* goto EXPR  or  goto &foo */
2668
2669         SV * const sv = POPs;
2670         SvGETMAGIC(sv);
2671
2672         /* This egregious kludge implements goto &subroutine */
2673         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2674             I32 cxix;
2675             PERL_CONTEXT *cx;
2676             CV *cv = MUTABLE_CV(SvRV(sv));
2677             AV *arg = GvAV(PL_defgv);
2678             I32 oldsave;
2679
2680         retry:
2681             if (!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                         goto retry;
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                         goto retry;
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             /* First do some returnish stuff. */
2702             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2703             FREETMPS;
2704             cxix = dopoptosub(cxstack_ix);
2705             if (cxix < cxstack_ix) {
2706                 if (cxix < 0) {
2707                     SvREFCNT_dec(cv);
2708                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2709                 }
2710                 dounwind(cxix);
2711             }
2712             TOPBLOCK(cx);
2713             SPAGAIN;
2714             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2715             if (CxTYPE(cx) == CXt_EVAL) {
2716                 SvREFCNT_dec(cv);
2717                 if (CxREALEVAL(cx))
2718                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2719                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2720                 else
2721                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2722                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2723             }
2724             else if (CxMULTICALL(cx))
2725             {
2726                 SvREFCNT_dec(cv);
2727                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2728             }
2729             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2730                 AV* av = cx->blk_sub.argarray;
2731
2732                 /* abandon the original @_ if it got reified or if it is
2733                    the same as the current @_ */
2734                 if (AvREAL(av) || av == arg) {
2735                     SvREFCNT_dec(av);
2736                     av = newAV();
2737                     AvREIFY_only(av);
2738                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2739                 }
2740                 else CLEAR_ARGARRAY(av);
2741             }
2742
2743             /* We donate this refcount later to the callee’s pad. */
2744             SvREFCNT_inc_simple_void(arg);
2745
2746             assert(PL_scopestack_ix == cx->blk_oldscopesp);
2747             oldsave = PL_scopestack[cx->blk_oldscopesp - 1];
2748             LEAVE_SCOPE(oldsave);
2749             PL_comppad = cx->blk_sub.prevcomppad;
2750             PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2751
2752             /* A destructor called during LEAVE_SCOPE could have undefined
2753              * our precious cv.  See bug #99850. */
2754             if (!CvROOT(cv) && !CvXSUB(cv)) {
2755                 const GV * const gv = CvGV(cv);
2756                 SvREFCNT_dec(arg);
2757                 if (gv) {
2758                     SV * const tmpstr = sv_newmortal();
2759                     gv_efullname3(tmpstr, gv, NULL);
2760                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2761                                SVfARG(tmpstr));
2762                 }
2763                 DIE(aTHX_ "Goto undefined subroutine");
2764             }
2765
2766             if (CxTYPE(cx) == CXt_SUB) {
2767                 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2768                 SvREFCNT_dec_NN(cx->blk_sub.cv);
2769             }
2770
2771             /* Now do some callish stuff. */
2772             SAVETMPS;
2773             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2774             if (CvISXSUB(cv)) {
2775                 SV **newsp;
2776                 I32 gimme;
2777                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2778                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2779                 SV** mark;
2780
2781                 PERL_UNUSED_VAR(newsp);
2782                 PERL_UNUSED_VAR(gimme);
2783
2784                 /* put GvAV(defgv) back onto stack */
2785                 if (items) {
2786                     EXTEND(SP, items+1); /* @_ could have been extended. */
2787                 }
2788                 mark = SP;
2789                 if (items) {
2790                     SSize_t index;
2791                     bool r = cBOOL(AvREAL(arg));
2792                     for (index=0; index<items; index++)
2793                     {
2794                         SV *sv;
2795                         if (m) {
2796                             SV ** const svp = av_fetch(arg, index, 0);
2797                             sv = svp ? *svp : NULL;
2798                         }
2799                         else sv = AvARRAY(arg)[index];
2800                         SP[index+1] = sv
2801                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2802                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2803                     }
2804                 }
2805                 SP += items;
2806                 SvREFCNT_dec(arg);
2807                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2808                     /* Restore old @_ */
2809                     arg = GvAV(PL_defgv);
2810                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2811                     SvREFCNT_dec(arg);
2812                 }
2813
2814                 retop = cx->blk_sub.retop;
2815                 /* XS subs don't have a CxSUB, so pop it */
2816                 POPBLOCK(cx, PL_curpm);
2817                 /* Push a mark for the start of arglist */
2818                 PUSHMARK(mark);
2819                 PUTBACK;
2820                 (void)(*CvXSUB(cv))(aTHX_ cv);
2821                 LEAVE;
2822                 goto _return;
2823             }
2824             else {
2825                 PADLIST * const padlist = CvPADLIST(cv);
2826                 cx->blk_sub.cv = cv;
2827                 cx->blk_sub.olddepth = CvDEPTH(cv);
2828
2829                 CvDEPTH(cv)++;
2830                 SvREFCNT_inc_simple_void_NN(cv);
2831                 if (CvDEPTH(cv) > 1) {
2832                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2833                         sub_crush_depth(cv);
2834                     pad_push(padlist, CvDEPTH(cv));
2835                 }
2836                 PL_curcop = cx->blk_oldcop;
2837                 cx->blk_sub.prevcomppad = PL_comppad;
2838                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2839                 if (CxHASARGS(cx))
2840                 {
2841                     CX_CURPAD_SAVE(cx->blk_sub);
2842
2843                     /* cx->blk_sub.argarray has no reference count, so we
2844                        need something to hang on to our argument array so
2845                        that cx->blk_sub.argarray does not end up pointing
2846                        to freed memory as the result of undef *_.  So put
2847                        it in the callee’s pad, donating our refer-
2848                        ence count. */
2849                     if (arg) {
2850                         SvREFCNT_dec(PAD_SVl(0));
2851                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2852                     }
2853
2854                     /* GvAV(PL_defgv) might have been modified on scope
2855                        exit, so restore it. */
2856                     if (arg != GvAV(PL_defgv)) {
2857                         AV * const av = GvAV(PL_defgv);
2858                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2859                         SvREFCNT_dec(av);
2860                     }
2861                 }
2862                 else SvREFCNT_dec(arg);
2863                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2864                     Perl_get_db_sub(aTHX_ NULL, cv);
2865                     if (PERLDB_GOTO) {
2866                         CV * const gotocv = get_cvs("DB::goto", 0);
2867                         if (gotocv) {
2868                             PUSHMARK( PL_stack_sp );
2869                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2870                             PL_stack_sp--;
2871                         }
2872                     }
2873                 }
2874                 retop = CvSTART(cv);
2875                 goto putback_return;
2876             }
2877         }
2878         else {
2879             /* goto EXPR */
2880             label       = SvPV_nomg_const(sv, label_len);
2881             label_flags = SvUTF8(sv);
2882         }
2883     }
2884     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2885         /* goto LABEL  or  dump LABEL */
2886         label       = cPVOP->op_pv;
2887         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2888         label_len   = strlen(label);
2889     }
2890     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2891
2892     PERL_ASYNC_CHECK();
2893
2894     if (label_len) {
2895         OP *gotoprobe = NULL;
2896         bool leaving_eval = FALSE;
2897         bool in_block = FALSE;
2898         PERL_CONTEXT *last_eval_cx = NULL;
2899
2900         /* find label */
2901
2902         PL_lastgotoprobe = NULL;
2903         *enterops = 0;
2904         for (ix = cxstack_ix; ix >= 0; ix--) {
2905             cx = &cxstack[ix];
2906             switch (CxTYPE(cx)) {
2907             case CXt_EVAL:
2908                 leaving_eval = TRUE;
2909                 if (!CxTRYBLOCK(cx)) {
2910                     gotoprobe = (last_eval_cx ?
2911                                 last_eval_cx->blk_eval.old_eval_root :
2912                                 PL_eval_root);
2913                     last_eval_cx = cx;
2914                     break;
2915                 }
2916                 /* else fall through */
2917             case CXt_LOOP_LAZYIV:
2918             case CXt_LOOP_LAZYSV:
2919             case CXt_LOOP_FOR:
2920             case CXt_LOOP_PLAIN:
2921             case CXt_GIVEN:
2922             case CXt_WHEN:
2923                 gotoprobe = OpSIBLING(cx->blk_oldcop);
2924                 break;
2925             case CXt_SUBST:
2926                 continue;
2927             case CXt_BLOCK:
2928                 if (ix) {
2929                     gotoprobe = OpSIBLING(cx->blk_oldcop);
2930                     in_block = TRUE;
2931                 } else
2932                     gotoprobe = PL_main_root;
2933                 break;
2934             case CXt_SUB:
2935                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2936                     gotoprobe = CvROOT(cx->blk_sub.cv);
2937                     break;
2938                 }
2939                 /* FALLTHROUGH */
2940             case CXt_FORMAT:
2941             case CXt_NULL:
2942                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2943             default:
2944                 if (ix)
2945                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2946                         CxTYPE(cx), (long) ix);
2947                 gotoprobe = PL_main_root;
2948                 break;
2949             }
2950             if (gotoprobe) {
2951                 OP *sibl1, *sibl2;
2952
2953                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2954                                     enterops, enterops + GOTO_DEPTH);
2955                 if (retop)
2956                     break;
2957                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2958                      sibl1->op_type == OP_UNSTACK &&
2959                      (sibl2 = OpSIBLING(sibl1)))
2960                 {
2961                     retop = dofindlabel(sibl2,
2962                                         label, label_len, label_flags, enterops,
2963                                         enterops + GOTO_DEPTH);
2964                     if (retop)
2965                         break;
2966                 }
2967             }
2968             PL_lastgotoprobe = gotoprobe;
2969         }
2970         if (!retop)
2971             DIE(aTHX_ "Can't find label %"UTF8f,
2972                        UTF8fARG(label_flags, label_len, label));
2973
2974         /* if we're leaving an eval, check before we pop any frames
2975            that we're not going to punt, otherwise the error
2976            won't be caught */
2977
2978         if (leaving_eval && *enterops && enterops[1]) {
2979             I32 i;
2980             for (i = 1; enterops[i]; i++)
2981                 if (enterops[i]->op_type == OP_ENTERITER)
2982                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2983         }
2984
2985         if (*enterops && enterops[1]) {
2986             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2987             if (enterops[i])
2988                 deprecate("\"goto\" to jump into a construct");
2989         }
2990
2991         /* pop unwanted frames */
2992
2993         if (ix < cxstack_ix) {
2994             I32 oldsave;
2995
2996             if (ix < 0)
2997                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
2998             dounwind(ix);
2999             TOPBLOCK(cx);
3000             oldsave = PL_scopestack[PL_scopestack_ix];
3001             LEAVE_SCOPE(oldsave);
3002         }
3003
3004         /* push wanted frames */
3005
3006         if (*enterops && enterops[1]) {
3007             OP * const oldop = PL_op;
3008             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3009             for (; enterops[ix]; ix++) {
3010                 PL_op = enterops[ix];
3011                 /* Eventually we may want to stack the needed arguments
3012                  * for each op.  For now, we punt on the hard ones. */
3013                 if (PL_op->op_type == OP_ENTERITER)
3014                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3015                 PL_op->op_ppaddr(aTHX);
3016             }
3017             PL_op = oldop;
3018         }
3019     }
3020
3021     if (do_dump) {
3022 #ifdef VMS
3023         if (!retop) retop = PL_main_start;
3024 #endif
3025         PL_restartop = retop;
3026         PL_do_undump = TRUE;
3027
3028         my_unexec();
3029
3030         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3031         PL_do_undump = FALSE;
3032     }
3033
3034     putback_return:
3035     PL_stack_sp = sp;
3036     _return:
3037     PERL_ASYNC_CHECK();
3038     return retop;
3039 }
3040
3041 PP(pp_exit)
3042 {
3043     dSP;
3044     I32 anum;
3045
3046     if (MAXARG < 1)
3047         anum = 0;
3048     else if (!TOPs) {
3049         anum = 0; (void)POPs;
3050     }
3051     else {
3052         anum = SvIVx(POPs);
3053 #ifdef VMS
3054         if (anum == 1
3055          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3056             anum = 0;
3057         VMSISH_HUSHED  =
3058             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3059 #endif
3060     }
3061     PL_exit_flags |= PERL_EXIT_EXPECTED;
3062     my_exit(anum);
3063     PUSHs(&PL_sv_undef);
3064     RETURN;
3065 }
3066
3067 /* Eval. */
3068
3069 STATIC void
3070 S_save_lines(pTHX_ AV *array, SV *sv)
3071 {
3072     const char *s = SvPVX_const(sv);
3073     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3074     I32 line = 1;
3075
3076     PERL_ARGS_ASSERT_SAVE_LINES;
3077
3078     while (s && s < send) {
3079         const char *t;
3080         SV * const tmpstr = newSV_type(SVt_PVMG);
3081
3082         t = (const char *)memchr(s, '\n', send - s);
3083         if (t)
3084             t++;
3085         else
3086             t = send;
3087
3088         sv_setpvn(tmpstr, s, t - s);
3089         av_store(array, line++, tmpstr);
3090         s = t;
3091     }
3092 }
3093
3094 /*
3095 =for apidoc docatch
3096
3097 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3098
3099 0 is used as continue inside eval,
3100
3101 3 is used for a die caught by an inner eval - continue inner loop
3102
3103 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3104 establish a local jmpenv to handle exception traps.
3105
3106 =cut
3107 */
3108 STATIC OP *
3109 S_docatch(pTHX_ OP *o)
3110 {
3111     int ret;
3112     OP * const oldop = PL_op;
3113     dJMPENV;
3114
3115 #ifdef DEBUGGING
3116     assert(CATCH_GET == TRUE);
3117 #endif
3118     PL_op = o;
3119
3120     JMPENV_PUSH(ret);
3121     switch (ret) {
3122     case 0:
3123         assert(cxstack_ix >= 0);
3124         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3125         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3126  redo_body:
3127         CALLRUNOPS(aTHX);
3128         break;
3129     case 3:
3130         /* die caught by an inner eval - continue inner loop */
3131         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3132             PL_restartjmpenv = NULL;
3133             PL_op = PL_restartop;
3134             PL_restartop = 0;
3135             goto redo_body;
3136         }
3137         /* FALLTHROUGH */
3138     default:
3139         JMPENV_POP;
3140         PL_op = oldop;
3141         JMPENV_JUMP(ret);
3142         NOT_REACHED; /* NOTREACHED */
3143     }
3144     JMPENV_POP;
3145     PL_op = oldop;
3146     return NULL;
3147 }
3148
3149
3150 /*
3151 =for apidoc find_runcv
3152
3153 Locate the CV corresponding to the currently executing sub or eval.
3154 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3155 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3156 entered.  (This allows debuggers to eval in the scope of the breakpoint
3157 rather than in the scope of the debugger itself.)
3158
3159 =cut
3160 */
3161
3162 CV*
3163 Perl_find_runcv(pTHX_ U32 *db_seqp)
3164 {
3165     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3166 }
3167
3168 /* If this becomes part of the API, it might need a better name. */
3169 CV *
3170 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3171 {
3172     PERL_SI      *si;
3173     int          level = 0;
3174
3175     if (db_seqp)
3176         *db_seqp =
3177             PL_curcop == &PL_compiling
3178                 ? PL_cop_seqmax
3179                 : PL_curcop->cop_seq;
3180
3181     for (si = PL_curstackinfo; si; si = si->si_prev) {
3182         I32 ix;
3183         for (ix = si->si_cxix; ix >= 0; ix--) {
3184             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3185             CV *cv = NULL;
3186             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3187                 cv = cx->blk_sub.cv;
3188                 /* skip DB:: code */
3189                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3190                     *db_seqp = cx->blk_oldcop->cop_seq;
3191                     continue;
3192                 }
3193                 if (cx->cx_type & CXp_SUB_RE)
3194                     continue;
3195             }
3196             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3197                 cv = cx->blk_eval.cv;
3198             if (cv) {
3199                 switch (cond) {
3200                 case FIND_RUNCV_padid_eq:
3201                     if (!CvPADLIST(cv)
3202                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3203                         continue;
3204                     return cv;
3205                 case FIND_RUNCV_level_eq:
3206                     if (level++ != arg) continue;
3207                     /* GERONIMO! */
3208                 default:
3209                     return cv;
3210                 }
3211             }
3212         }
3213     }
3214     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3215 }
3216
3217
3218 /* Run yyparse() in a setjmp wrapper. Returns:
3219  *   0: yyparse() successful
3220  *   1: yyparse() failed
3221  *   3: yyparse() died
3222  */
3223 STATIC int
3224 S_try_yyparse(pTHX_ int gramtype)
3225 {
3226     int ret;
3227     dJMPENV;
3228
3229     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3230     JMPENV_PUSH(ret);
3231     switch (ret) {
3232     case 0:
3233         ret = yyparse(gramtype) ? 1 : 0;
3234         break;
3235     case 3:
3236         break;
3237     default:
3238         JMPENV_POP;
3239         JMPENV_JUMP(ret);
3240         NOT_REACHED; /* NOTREACHED */
3241     }
3242     JMPENV_POP;
3243     return ret;
3244 }
3245
3246
3247 /* Compile a require/do or an eval ''.
3248  *
3249  * outside is the lexically enclosing CV (if any) that invoked us.
3250  * seq     is the current COP scope value.
3251  * hh      is the saved hints hash, if any.
3252  *
3253  * Returns a bool indicating whether the compile was successful; if so,
3254  * PL_eval_start contains the first op of the compiled code; otherwise,
3255  * pushes undef.
3256  *
3257  * This function is called from two places: pp_require and pp_entereval.
3258  * These can be distinguished by whether PL_op is entereval.
3259  */
3260
3261 STATIC bool
3262 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3263 {
3264     dSP;
3265     OP * const saveop = PL_op;
3266     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3267     COP * const oldcurcop = PL_curcop;
3268     bool in_require = (saveop->op_type == OP_REQUIRE);
3269     int yystatus;
3270     CV *evalcv;
3271
3272     PL_in_eval = (in_require
3273                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3274                   : (EVAL_INEVAL |
3275                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3276                             ? EVAL_RE_REPARSING : 0)));
3277
3278     PUSHMARK(SP);
3279
3280     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3281     CvEVAL_on(evalcv);
3282     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3283     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3284     cxstack[cxstack_ix].blk_gimme = gimme;
3285
3286     CvOUTSIDE_SEQ(evalcv) = seq;
3287     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3288
3289     /* set up a scratch pad */
3290
3291     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3292     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3293
3294
3295     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3296
3297     /* make sure we compile in the right package */
3298
3299     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3300         SAVEGENERICSV(PL_curstash);
3301         PL_curstash = (HV *)CopSTASH(PL_curcop);
3302         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3303         else SvREFCNT_inc_simple_void(PL_curstash);
3304     }
3305     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3306     SAVESPTR(PL_beginav);
3307     PL_beginav = newAV();
3308     SAVEFREESV(PL_beginav);
3309     SAVESPTR(PL_unitcheckav);
3310     PL_unitcheckav = newAV();
3311     SAVEFREESV(PL_unitcheckav);
3312
3313
3314     ENTER_with_name("evalcomp");
3315     SAVESPTR(PL_compcv);
3316     PL_compcv = evalcv;
3317
3318     /* try to compile it */
3319
3320     PL_eval_root = NULL;
3321     PL_curcop = &PL_compiling;
3322     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3323         PL_in_eval |= EVAL_KEEPERR;
3324     else
3325         CLEAR_ERRSV();
3326
3327     SAVEHINTS();
3328     if (clear_hints) {
3329         PL_hints = 0;
3330         hv_clear(GvHV(PL_hintgv));
3331     }
3332     else {
3333         PL_hints = saveop->op_private & OPpEVAL_COPHH
3334                      ? oldcurcop->cop_hints : saveop->op_targ;
3335
3336         /* making 'use re eval' not be in scope when compiling the
3337          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3338          * infinite recursion when S_has_runtime_code() gives a false
3339          * positive: the second time round, HINT_RE_EVAL isn't set so we
3340          * don't bother calling S_has_runtime_code() */
3341         if (PL_in_eval & EVAL_RE_REPARSING)
3342             PL_hints &= ~HINT_RE_EVAL;
3343
3344         if (hh) {
3345             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3346             SvREFCNT_dec(GvHV(PL_hintgv));
3347             GvHV(PL_hintgv) = hh;
3348         }
3349     }
3350     SAVECOMPILEWARNINGS();
3351     if (clear_hints) {
3352         if (PL_dowarn & G_WARN_ALL_ON)
3353             PL_compiling.cop_warnings = pWARN_ALL ;
3354         else if (PL_dowarn & G_WARN_ALL_OFF)
3355             PL_compiling.cop_warnings = pWARN_NONE ;
3356         else
3357             PL_compiling.cop_warnings = pWARN_STD ;
3358     }
3359     else {
3360         PL_compiling.cop_warnings =
3361             DUP_WARNINGS(oldcurcop->cop_warnings);
3362         cophh_free(CopHINTHASH_get(&PL_compiling));
3363         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3364             /* The label, if present, is the first entry on the chain. So rather
3365                than writing a blank label in front of it (which involves an
3366                allocation), just use the next entry in the chain.  */
3367             PL_compiling.cop_hints_hash
3368                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3369             /* Check the assumption that this removed the label.  */
3370             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3371         }
3372         else
3373             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3374     }
3375
3376     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3377
3378     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3379      * so honour CATCH_GET and trap it here if necessary */
3380
3381     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3382
3383     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3384         SV **newsp;                     /* Used by POPBLOCK. */
3385         PERL_CONTEXT *cx;
3386         I32 optype;                     /* Used by POPEVAL. */
3387         SV *namesv;
3388         SV *errsv = NULL;
3389
3390         cx = NULL;
3391         namesv = NULL;
3392         PERL_UNUSED_VAR(newsp);
3393         PERL_UNUSED_VAR(optype);
3394
3395         /* note that if yystatus == 3, then the EVAL CX block has already
3396          * been popped, and various vars restored */
3397         PL_op = saveop;
3398         if (yystatus != 3) {
3399             if (PL_eval_root) {
3400                 op_free(PL_eval_root);
3401                 PL_eval_root = NULL;
3402             }
3403             SP = PL_stack_base + POPMARK;       /* pop original mark */
3404             POPBLOCK(cx,PL_curpm);
3405             POPEVAL(cx);
3406             namesv = cx->blk_eval.old_namesv;
3407             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3408             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3409         }
3410
3411         errsv = ERRSV;
3412         if (in_require) {
3413             if (!cx) {
3414                 /* If cx is still NULL, it means that we didn't go in the
3415                  * POPEVAL branch. */
3416                 cx = &cxstack[cxstack_ix];
3417                 assert(CxTYPE(cx) == CXt_EVAL);
3418                 namesv = cx->blk_eval.old_namesv;
3419             }
3420             (void)hv_store(GvHVn(PL_incgv),
3421                            SvPVX_const(namesv),
3422                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3423                            &PL_sv_undef, 0);
3424             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3425                        SVfARG(errsv
3426                                 ? errsv
3427                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3428         }
3429         else {
3430             if (!*(SvPV_nolen_const(errsv))) {
3431                 sv_setpvs(errsv, "Compilation error");
3432             }
3433         }
3434         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3435         PUTBACK;
3436         return FALSE;
3437     }
3438     else
3439         LEAVE_with_name("evalcomp");
3440
3441     CopLINE_set(&PL_compiling, 0);
3442     SAVEFREEOP(PL_eval_root);
3443     cv_forget_slab(evalcv);
3444
3445     DEBUG_x(dump_eval());
3446
3447     /* Register with debugger: */
3448     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3449         CV * const cv = get_cvs("DB::postponed", 0);
3450         if (cv) {
3451             dSP;
3452             PUSHMARK(SP);
3453             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3454             PUTBACK;
3455             call_sv(MUTABLE_SV(cv), G_DISCARD);
3456         }
3457     }
3458
3459     if (PL_unitcheckav) {
3460         OP *es = PL_eval_start;
3461         call_list(PL_scopestack_ix, PL_unitcheckav);
3462         PL_eval_start = es;
3463     }
3464
3465     /* compiled okay, so do it */
3466
3467     CvDEPTH(evalcv) = 1;
3468     SP = PL_stack_base + POPMARK;               /* pop original mark */
3469     PL_op = saveop;                     /* The caller may need it. */
3470     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3471
3472     PUTBACK;
3473     return TRUE;
3474 }
3475
3476 STATIC PerlIO *
3477 S_check_type_and_open(pTHX_ SV *name)
3478 {
3479     Stat_t st;
3480     STRLEN len;
3481     PerlIO * retio;
3482     const char *p = SvPV_const(name, len);
3483     int st_rc;
3484
3485     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3486
3487     /* checking here captures a reasonable error message when
3488      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3489      * user gets a confusing message about looking for the .pmc file
3490      * rather than for the .pm file so do the check in S_doopen_pm when
3491      * PMC is on instead of here. S_doopen_pm calls this func.
3492      * This check prevents a \0 in @INC causing problems.
3493      */
3494 #ifdef PERL_DISABLE_PMC
3495     if (!IS_SAFE_PATHNAME(p, len, "require"))
3496         return NULL;
3497 #endif
3498
3499     /* on Win32 stat is expensive (it does an open() and close() twice and
3500        a couple other IO calls), the open will fail with a dir on its own with
3501        errno EACCES, so only do a stat to separate a dir from a real EACCES
3502        caused by user perms */
3503 #ifndef WIN32
3504     /* we use the value of errno later to see how stat() or open() failed.
3505      * We don't want it set if the stat succeeded but we still failed,
3506      * such as if the name exists, but is a directory */
3507     errno = 0;
3508
3509     st_rc = PerlLIO_stat(p, &st);
3510
3511     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3512         return NULL;
3513     }
3514 #endif
3515
3516     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3517 #ifdef WIN32
3518     /* EACCES stops the INC search early in pp_require to implement
3519        feature RT #113422 */
3520     if(!retio && errno == EACCES) { /* exists but probably a directory */
3521         int eno;
3522         st_rc = PerlLIO_stat(p, &st);
3523         if (st_rc >= 0) {
3524             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3525                 eno = 0;
3526             else
3527                 eno = EACCES;
3528             errno = eno;
3529         }
3530     }
3531 #endif
3532     return retio;
3533 }
3534
3535 #ifndef PERL_DISABLE_PMC
3536 STATIC PerlIO *
3537 S_doopen_pm(pTHX_ SV *name)
3538 {
3539     STRLEN namelen;
3540     const char *p = SvPV_const(name, namelen);
3541
3542     PERL_ARGS_ASSERT_DOOPEN_PM;
3543
3544     /* check the name before trying for the .pmc name to avoid the
3545      * warning referring to the .pmc which the user probably doesn't
3546      * know or care about
3547      */
3548     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3549         return NULL;
3550
3551     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3552         SV *const pmcsv = sv_newmortal();
3553         PerlIO * pmcio;
3554
3555         SvSetSV_nosteal(pmcsv,name);
3556         sv_catpvs(pmcsv, "c");
3557
3558         pmcio = check_type_and_open(pmcsv);
3559         if (pmcio)
3560             return pmcio;
3561     }
3562     return check_type_and_open(name);
3563 }
3564 #else
3565 #  define doopen_pm(name) check_type_and_open(name)
3566 #endif /* !PERL_DISABLE_PMC */
3567
3568 /* require doesn't search for absolute names, or when the name is
3569    explicitly relative the current directory */
3570 PERL_STATIC_INLINE bool
3571 S_path_is_searchable(const char *name)
3572 {
3573     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3574
3575     if (PERL_FILE_IS_ABSOLUTE(name)
3576 #ifdef WIN32
3577         || (*name == '.' && ((name[1] == '/' ||
3578                              (name[1] == '.' && name[2] == '/'))
3579                          || (name[1] == '\\' ||
3580                              ( name[1] == '.' && name[2] == '\\')))
3581             )
3582 #else
3583         || (*name == '.' && (name[1] == '/' ||
3584                              (name[1] == '.' && name[2] == '/')))
3585 #endif
3586          )
3587     {
3588         return FALSE;
3589     }
3590     else
3591         return TRUE;
3592 }
3593
3594
3595 /* also used for: pp_dofile() */
3596
3597 PP(pp_require)
3598 {
3599     dSP;
3600     PERL_CONTEXT *cx;
3601     SV *sv;
3602     const char *name;
3603     STRLEN len;
3604     char * unixname;
3605     STRLEN unixlen;
3606 #ifdef VMS
3607     int vms_unixname = 0;
3608     char *unixdir;
3609 #endif
3610     const char *tryname = NULL;
3611     SV *namesv = NULL;
3612     const I32 gimme = GIMME_V;
3613     int filter_has_file = 0;
3614     PerlIO *tryrsfp = NULL;
3615     SV *filter_cache = NULL;
3616     SV *filter_state = NULL;
3617     SV *filter_sub = NULL;
3618     SV *hook_sv = NULL;
3619     OP *op;
3620     int saved_errno;
3621     bool path_searchable;
3622
3623     sv = POPs;
3624     SvGETMAGIC(sv);
3625     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3626         sv = sv_2mortal(new_version(sv));
3627         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3628             upg_version(PL_patchlevel, TRUE);
3629         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3630             if ( vcmp(sv,PL_patchlevel) <= 0 )
3631                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3632                     SVfARG(sv_2mortal(vnormal(sv))),
3633                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3634                 );
3635         }
3636         else {
3637             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3638                 I32 first = 0;
3639                 AV *lav;
3640                 SV * const req = SvRV(sv);
3641                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3642
3643                 /* get the left hand term */
3644                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3645
3646                 first  = SvIV(*av_fetch(lav,0,0));
3647                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3648                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3649                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3650                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3651                    ) {
3652                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3653                         "%"SVf", stopped",
3654                         SVfARG(sv_2mortal(vnormal(req))),
3655                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3656                     );
3657                 }
3658                 else { /* probably 'use 5.10' or 'use 5.8' */
3659                     SV *hintsv;
3660                     I32 second = 0;
3661
3662                     if (av_tindex(lav)>=1)
3663                         second = SvIV(*av_fetch(lav,1,0));
3664
3665                     second /= second >= 600  ? 100 : 10;
3666                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3667                                            (int)first, (int)second);
3668                     upg_version(hintsv, TRUE);
3669
3670                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3671                         "--this is only %"SVf", stopped",
3672                         SVfARG(sv_2mortal(vnormal(req))),
3673                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3674                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3675                     );
3676                 }
3677             }
3678         }
3679
3680         RETPUSHYES;
3681     }
3682     if (!SvOK(sv))
3683         DIE(aTHX_ "Missing or undefined argument to require");
3684     name = SvPV_nomg_const(sv, len);
3685     if (!(name && len > 0 && *name))
3686         DIE(aTHX_ "Missing or undefined argument to require");
3687
3688     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3689         DIE(aTHX_ "Can't locate %s:   %s",
3690             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3691                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3692             Strerror(ENOENT));
3693     }
3694     TAINT_PROPER("require");
3695
3696     path_searchable = path_is_searchable(name);
3697
3698 #ifdef VMS
3699     /* The key in the %ENV hash is in the syntax of file passed as the argument
3700      * usually this is in UNIX format, but sometimes in VMS format, which
3701      * can result in a module being pulled in more than once.
3702      * To prevent this, the key must be stored in UNIX format if the VMS
3703      * name can be translated to UNIX.
3704      */
3705
3706     if ((unixname =
3707           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3708          != NULL) {
3709         unixlen = strlen(unixname);
3710         vms_unixname = 1;
3711     }
3712     else
3713 #endif
3714     {
3715         /* if not VMS or VMS name can not be translated to UNIX, pass it
3716          * through.
3717          */
3718         unixname = (char *) name;
3719         unixlen = len;
3720     }
3721     if (PL_op->op_type == OP_REQUIRE) {
3722         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3723                                           unixname, unixlen, 0);
3724         if ( svp ) {
3725             if (*svp != &PL_sv_undef)
3726                 RETPUSHYES;
3727             else
3728                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3729                             "Compilation failed in require", unixname);
3730         }
3731     }
3732
3733     LOADING_FILE_PROBE(unixname);
3734
3735     /* prepare to compile file */
3736
3737     if (!path_searchable) {
3738         /* At this point, name is SvPVX(sv)  */
3739         tryname = name;
3740         tryrsfp = doopen_pm(sv);
3741     }
3742     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3743         AV * const ar = GvAVn(PL_incgv);
3744         SSize_t i;
3745 #ifdef VMS
3746         if (vms_unixname)
3747 #endif
3748         {
3749             SV *nsv = sv;
3750             namesv = newSV_type(SVt_PV);
3751             for (i = 0; i <= AvFILL(ar); i++) {
3752                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3753
3754                 SvGETMAGIC(dirsv);
3755                 if (SvROK(dirsv)) {
3756                     int count;
3757                     SV **svp;
3758                     SV *loader = dirsv;
3759
3760                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3761                         && !SvOBJECT(SvRV(loader)))
3762                     {
3763                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3764                         SvGETMAGIC(loader);
3765                     }
3766
3767                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3768                                    PTR2UV(SvRV(dirsv)), name);
3769                     tryname = SvPVX_const(namesv);
3770                     tryrsfp = NULL;
3771
3772                     if (SvPADTMP(nsv)) {
3773                         nsv = sv_newmortal();
3774                         SvSetSV_nosteal(nsv,sv);
3775                     }
3776
3777                     ENTER_with_name("call_INC");
3778                     SAVETMPS;
3779                     EXTEND(SP, 2);
3780
3781                     PUSHMARK(SP);
3782                     PUSHs(dirsv);
3783                     PUSHs(nsv);
3784                     PUTBACK;
3785                     if (SvGMAGICAL(loader)) {
3786                         SV *l = sv_newmortal();
3787                         sv_setsv_nomg(l, loader);
3788                         loader = l;
3789                     }
3790                     if (sv_isobject(loader))
3791                         count = call_method("INC", G_ARRAY);
3792                     else
3793                         count = call_sv(loader, G_ARRAY);
3794                     SPAGAIN;
3795
3796                     if (count > 0) {
3797                         int i = 0;
3798                         SV *arg;
3799
3800                         SP -= count - 1;
3801                         arg = SP[i++];
3802
3803                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3804                             && !isGV_with_GP(SvRV(arg))) {
3805                             filter_cache = SvRV(arg);
3806
3807                             if (i < count) {
3808                                 arg = SP[i++];
3809                             }
3810                         }
3811
3812                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3813                             arg = SvRV(arg);
3814                         }
3815
3816                         if (isGV_with_GP(arg)) {
3817                             IO * const io = GvIO((const GV *)arg);
3818
3819                             ++filter_has_file;
3820
3821                             if (io) {
3822                                 tryrsfp = IoIFP(io);
3823                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3824                                     PerlIO_close(IoOFP(io));
3825                                 }
3826                                 IoIFP(io) = NULL;
3827                                 IoOFP(io) = NULL;
3828                             }
3829
3830                             if (i < count) {
3831                                 arg = SP[i++];
3832                             }
3833                         }
3834
3835                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3836                             filter_sub = arg;
3837                             SvREFCNT_inc_simple_void_NN(filter_sub);
3838
3839                             if (i < count) {
3840                                 filter_state = SP[i];
3841                                 SvREFCNT_inc_simple_void(filter_state);
3842                             }
3843                         }
3844
3845                         if (!tryrsfp && (filter_cache || filter_sub)) {
3846                             tryrsfp = PerlIO_open(BIT_BUCKET,
3847                                                   PERL_SCRIPT_MODE);
3848                         }
3849                         SP--;
3850                     }
3851
3852                     /* FREETMPS may free our filter_cache */
3853                     SvREFCNT_inc_simple_void(filter_cache);
3854
3855                     PUTBACK;
3856                     FREETMPS;
3857                     LEAVE_with_name("call_INC");
3858
3859                     /* Now re-mortalize it. */
3860                     sv_2mortal(filter_cache);
3861
3862                     /* Adjust file name if the hook has set an %INC entry.
3863                        This needs to happen after the FREETMPS above.  */
3864                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3865                     if (svp)
3866                         tryname = SvPV_nolen_const(*svp);
3867
3868                     if (tryrsfp) {
3869                         hook_sv = dirsv;
3870                         break;
3871                     }
3872
3873                     filter_has_file = 0;
3874                     filter_cache = NULL;
3875                     if (filter_state) {
3876                         SvREFCNT_dec_NN(filter_state);
3877                         filter_state = NULL;
3878                     }
3879                     if (filter_sub) {
3880                         SvREFCNT_dec_NN(filter_sub);
3881                         filter_sub = NULL;
3882                     }
3883                 }
3884                 else {
3885                   if (path_searchable) {
3886                     const char *dir;
3887                     STRLEN dirlen;
3888
3889                     if (SvOK(dirsv)) {
3890                         dir = SvPV_nomg_const(dirsv, dirlen);
3891                     } else {
3892                         dir = "";
3893                         dirlen = 0;
3894                     }
3895
3896                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3897                         continue;
3898 #ifdef VMS
3899                     if ((unixdir =
3900                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3901                          == NULL)
3902                         continue;
3903                     sv_setpv(namesv, unixdir);
3904                     sv_catpv(namesv, unixname);
3905 #else
3906 #  ifdef __SYMBIAN32__
3907                     if (PL_origfilename[0] &&
3908                         PL_origfilename[1] == ':' &&
3909                         !(dir[0] && dir[1] == ':'))
3910                         Perl_sv_setpvf(aTHX_ namesv,
3911                                        "%c:%s\\%s",
3912                                        PL_origfilename[0],
3913                                        dir, name);
3914                     else
3915                         Perl_sv_setpvf(aTHX_ namesv,
3916                                        "%s\\%s",
3917                                        dir, name);
3918 #  else
3919                     /* The equivalent of
3920                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3921                        but without the need to parse the format string, or
3922                        call strlen on either pointer, and with the correct
3923                        allocation up front.  */
3924                     {
3925                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3926
3927                         memcpy(tmp, dir, dirlen);
3928                         tmp +=dirlen;
3929
3930                         /* Avoid '<dir>//<file>' */
3931                         if (!dirlen || *(tmp-1) != '/') {
3932                             *tmp++ = '/';
3933                         } else {
3934                             /* So SvCUR_set reports the correct length below */
3935                             dirlen--;
3936                         }
3937
3938                         /* name came from an SV, so it will have a '\0' at the
3939                            end that we can copy as part of this memcpy().  */
3940                         memcpy(tmp, name, len + 1);
3941
3942                         SvCUR_set(namesv, dirlen + len + 1);
3943                         SvPOK_on(namesv);
3944                     }
3945 #  endif
3946 #endif
3947                     TAINT_PROPER("require");
3948                     tryname = SvPVX_const(namesv);
3949                     tryrsfp = doopen_pm(namesv);
3950                     if (tryrsfp) {
3951                         if (tryname[0] == '.' && tryname[1] == '/') {
3952                             ++tryname;
3953                             while (*++tryname == '/') {}
3954                         }
3955                         break;
3956                     }
3957                     else if (errno == EMFILE || errno == EACCES) {
3958                         /* no point in trying other paths if out of handles;
3959                          * on the other hand, if we couldn't open one of the
3960                          * files, then going on with the search could lead to
3961                          * unexpected results; see perl #113422
3962                          */
3963                         break;
3964                     }
3965                   }
3966                 }
3967             }
3968         }
3969     }
3970     saved_errno = errno; /* sv_2mortal can realloc things */
3971     sv_2mortal(namesv);
3972     if (!tryrsfp) {
3973         if (PL_op->op_type == OP_REQUIRE) {
3974             if(saved_errno == EMFILE || saved_errno == EACCES) {
3975                 /* diag_listed_as: Can't locate %s */
3976                 DIE(aTHX_ "Can't locate %s:   %s: %s",
3977                     name, tryname, Strerror(saved_errno));
3978             } else {
3979                 if (namesv) {                   /* did we lookup @INC? */
3980                     AV * const ar = GvAVn(PL_incgv);
3981                     SSize_t i;
3982                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
3983                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3984                     for (i = 0; i <= AvFILL(ar); i++) {
3985                         sv_catpvs(inc, " ");
3986                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3987                     }
3988                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3989                         const char *c, *e = name + len - 3;
3990                         sv_catpv(msg, " (you may need to install the ");
3991                         for (c = name; c < e; c++) {
3992                             if (*c == '/') {
3993                                 sv_catpvs(msg, "::");
3994                             }
3995                             else {
3996                                 sv_catpvn(msg, c, 1);
3997                             }
3998                         }
3999                         sv_catpv(msg, " module)");
4000                     }
4001                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4002                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4003                     }
4004                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4005                         sv_catpv(msg, " (did you run h2ph?)");
4006                     }
4007
4008                     /* diag_listed_as: Can't locate %s */
4009                     DIE(aTHX_
4010                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4011                         name, msg, inc);
4012                 }
4013             }
4014             DIE(aTHX_ "Can't locate %s", name);
4015         }
4016
4017         CLEAR_ERRSV();
4018         RETPUSHUNDEF;
4019     }
4020     else
4021         SETERRNO(0, SS_NORMAL);
4022
4023     /* Assume success here to prevent recursive requirement. */
4024     /* name is never assigned to again, so len is still strlen(name)  */
4025     /* Check whether a hook in @INC has already filled %INC */
4026     if (!hook_sv) {
4027         (void)hv_store(GvHVn(PL_incgv),
4028                        unixname, unixlen, newSVpv(tryname,0),0);
4029     } else {
4030         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4031         if (!svp)
4032             (void)hv_store(GvHVn(PL_incgv),
4033                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4034     }
4035
4036     ENTER_with_name("eval");
4037     SAVETMPS;
4038     SAVECOPFILE_FREE(&PL_compiling);
4039     CopFILE_set(&PL_compiling, tryname);
4040     lex_start(NULL, tryrsfp, 0);
4041
4042     if (filter_sub || filter_cache) {
4043         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4044            than hanging another SV from it. In turn, filter_add() optionally
4045            takes the SV to use as the filter (or creates a new SV if passed
4046            NULL), so simply pass in whatever value filter_cache has.  */
4047         SV * const fc = filter_cache ? newSV(0) : NULL;
4048         SV *datasv;
4049         if (fc) sv_copypv(fc, filter_cache);
4050         datasv = filter_add(S_run_user_filter, fc);
4051         IoLINES(datasv) = filter_has_file;
4052         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4053         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4054     }
4055
4056     /* switch to eval mode */
4057     PUSHBLOCK(cx, CXt_EVAL, SP);
4058     PUSHEVAL(cx, name);
4059     cx->blk_eval.retop = PL_op->op_next;
4060
4061     SAVECOPLINE(&PL_compiling);
4062     CopLINE_set(&PL_compiling, 0);
4063
4064     PUTBACK;
4065
4066     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4067         op = DOCATCH(PL_eval_start);
4068     else
4069         op = PL_op->op_next;
4070
4071     LOADED_FILE_PROBE(unixname);
4072
4073     return op;
4074 }
4075
4076 /* This is a op added to hold the hints hash for
4077    pp_entereval. The hash can be modified by the code
4078    being eval'ed, so we return a copy instead. */
4079
4080 PP(pp_hintseval)
4081 {
4082     dSP;
4083     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4084     RETURN;
4085 }
4086
4087
4088 PP(pp_entereval)
4089 {
4090     dSP;
4091     PERL_CONTEXT *cx;
4092     SV *sv;
4093     const I32 gimme = GIMME_V;
4094     const U32 was = PL_breakable_sub_gen;
4095     char tbuf[TYPE_DIGITS(long) + 12];
4096     bool saved_delete = FALSE;
4097     char *tmpbuf = tbuf;
4098     STRLEN len;
4099     CV* runcv;
4100     U32 seq, lex_flags = 0;
4101     HV *saved_hh = NULL;
4102     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4103
4104     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4105         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4106     }
4107     else if (PL_hints & HINT_LOCALIZE_HH || (
4108                 PL_op->op_private & OPpEVAL_COPHH
4109              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4110             )) {
4111         saved_hh = cop_hints_2hv(PL_curcop, 0);
4112         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4113     }
4114     sv = POPs;
4115     if (!SvPOK(sv)) {
4116         /* make sure we've got a plain PV (no overload etc) before testing
4117          * for taint. Making a copy here is probably overkill, but better
4118          * safe than sorry */
4119         STRLEN len;
4120         const char * const p = SvPV_const(sv, len);
4121
4122         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4123         lex_flags |= LEX_START_COPIED;
4124
4125         if (bytes && SvUTF8(sv))
4126             SvPVbyte_force(sv, len);
4127     }
4128     else if (bytes && SvUTF8(sv)) {
4129         /* Don't modify someone else's scalar */
4130         STRLEN len;
4131         sv = newSVsv(sv);
4132         (void)sv_2mortal(sv);
4133         SvPVbyte_force(sv,len);
4134         lex_flags |= LEX_START_COPIED;
4135     }
4136
4137     TAINT_IF(SvTAINTED(sv));
4138     TAINT_PROPER("eval");
4139
4140     ENTER_with_name("eval");
4141     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4142                            ? LEX_IGNORE_UTF8_HINTS
4143                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4144                         )
4145              );
4146     SAVETMPS;
4147
4148     /* switch to eval mode */
4149
4150     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4151         SV * const temp_sv = sv_newmortal();
4152         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4153                        (unsigned long)++PL_evalseq,
4154                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4155         tmpbuf = SvPVX(temp_sv);
4156         len = SvCUR(temp_sv);
4157     }
4158     else
4159         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4160     SAVECOPFILE_FREE(&PL_compiling);
4161     CopFILE_set(&PL_compiling, tmpbuf+2);
4162     SAVECOPLINE(&PL_compiling);
4163     CopLINE_set(&PL_compiling, 1);
4164     /* special case: an eval '' executed within the DB package gets lexically
4165      * placed in the first non-DB CV rather than the current CV - this
4166      * allows the debugger to execute code, find lexicals etc, in the
4167      * scope of the code being debugged. Passing &seq gets find_runcv
4168      * to do the dirty work for us */
4169     runcv = find_runcv(&seq);
4170
4171     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4172     PUSHEVAL(cx, 0);
4173     cx->blk_eval.retop = PL_op->op_next;
4174
4175     /* prepare to compile string */
4176
4177     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4178         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4179     else {
4180         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4181            deleting the eval's FILEGV from the stash before gv_check() runs
4182            (i.e. before run-time proper). To work around the coredump that
4183            ensues, we always turn GvMULTI_on for any globals that were
4184            introduced within evals. See force_ident(). GSAR 96-10-12 */
4185         char *const safestr = savepvn(tmpbuf, len);
4186         SAVEDELETE(PL_defstash, safestr, len);
4187         saved_delete = TRUE;
4188     }
4189
4190     PUTBACK;
4191
4192     if (doeval(gimme, runcv, seq, saved_hh)) {
4193         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4194             ?  PERLDB_LINE_OR_SAVESRC
4195             :  PERLDB_SAVESRC_NOSUBS) {
4196             /* Retain the filegv we created.  */
4197         } else if (!saved_delete) {
4198             char *const safestr = savepvn(tmpbuf, len);
4199             SAVEDELETE(PL_defstash, safestr, len);
4200         }
4201         return DOCATCH(PL_eval_start);
4202     } else {
4203         /* We have already left the scope set up earlier thanks to the LEAVE
4204            in doeval().  */
4205         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4206             ?  PERLDB_LINE_OR_SAVESRC
4207             :  PERLDB_SAVESRC_INVALID) {
4208             /* Retain the filegv we created.  */
4209         } else if (!saved_delete) {
4210             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4211         }
4212         return PL_op->op_next;
4213     }
4214 }
4215
4216 PP(pp_leaveeval)
4217 {
4218     dSP;
4219     SV **newsp;
4220     PMOP *newpm;
4221     I32 gimme;
4222     PERL_CONTEXT *cx;
4223     OP *retop;
4224     I32 optype;
4225     SV *namesv;
4226     CV *evalcv;
4227     /* grab this value before POPEVAL restores old PL_in_eval */
4228     bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4229
4230     PERL_ASYNC_CHECK();
4231     POPBLOCK(cx,newpm);
4232     POPEVAL(cx);
4233     namesv = cx->blk_eval.old_namesv;
4234     retop = cx->blk_eval.retop;
4235     evalcv = cx->blk_eval.cv;
4236
4237     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4238                                 gimme, SVs_TEMP, FALSE);
4239     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4240
4241 #ifdef DEBUGGING
4242     assert(CvDEPTH(evalcv) == 1);
4243 #endif
4244     CvDEPTH(evalcv) = 0;
4245
4246     if (optype == OP_REQUIRE &&
4247         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4248     {
4249         /* Unassume the success we assumed earlier. */
4250         (void)hv_delete(GvHVn(PL_incgv),
4251                         SvPVX_const(namesv),
4252                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4253                         G_DISCARD);
4254         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4255         NOT_REACHED; /* NOTREACHED */
4256         /* die_unwind() did LEAVE, or we won't be here */
4257     }
4258     else {
4259         LEAVE_with_name("eval");
4260         if (!keep)
4261             CLEAR_ERRSV();
4262     }
4263
4264     RETURNOP(retop);
4265 }
4266
4267 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4268    close to the related Perl_create_eval_scope.  */
4269 void
4270 Perl_delete_eval_scope(pTHX)
4271 {
4272     SV **newsp;
4273     PMOP *newpm;
4274     I32 gimme;
4275     PERL_CONTEXT *cx;
4276     I32 optype;
4277
4278     POPBLOCK(cx,newpm);
4279     POPEVAL(cx);
4280     PL_curpm = newpm;
4281     LEAVE_with_name("eval_scope");
4282     PERL_UNUSED_VAR(newsp);
4283     PERL_UNUSED_VAR(gimme);
4284     PERL_UNUSED_VAR(optype);
4285 }
4286
4287 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4288    also needed by Perl_fold_constants.  */
4289 PERL_CONTEXT *
4290 Perl_create_eval_scope(pTHX_ U32 flags)
4291 {
4292     PERL_CONTEXT *cx;
4293     const I32 gimme = GIMME_V;
4294
4295     ENTER_with_name("eval_scope");
4296     SAVETMPS;
4297
4298     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4299     PUSHEVAL(cx, 0);
4300
4301     PL_in_eval = EVAL_INEVAL;
4302     if (flags & G_KEEPERR)
4303         PL_in_eval |= EVAL_KEEPERR;
4304     else
4305         CLEAR_ERRSV();
4306     if (flags & G_FAKINGEVAL) {
4307         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4308     }
4309     return cx;
4310 }
4311
4312 PP(pp_entertry)
4313 {
4314     PERL_CONTEXT * const cx = create_eval_scope(0);
4315     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4316     return DOCATCH(PL_op->op_next);
4317 }
4318
4319 PP(pp_leavetry)
4320 {
4321     dSP;
4322     SV **newsp;
4323     PMOP *newpm;
4324     I32 gimme;
4325     PERL_CONTEXT *cx;
4326     I32 optype;
4327     OP *retop;
4328
4329     PERL_ASYNC_CHECK();
4330     POPBLOCK(cx,newpm);
4331     retop = cx->blk_eval.retop;
4332     POPEVAL(cx);
4333     PERL_UNUSED_VAR(optype);
4334
4335     SP = leave_common(newsp, SP, newsp, gimme,
4336                                SVs_PADTMP|SVs_TEMP, FALSE);
4337     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4338
4339     LEAVE_with_name("eval_scope");
4340     CLEAR_ERRSV();
4341     RETURNOP(retop);
4342 }
4343
4344 PP(pp_entergiven)
4345 {
4346     dSP;
4347     PERL_CONTEXT *cx;
4348     const I32 gimme = GIMME_V;
4349
4350     ENTER_with_name("given");
4351     SAVETMPS;
4352
4353     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4354     SAVE_DEFSV;
4355     DEFSV_set(POPs);
4356
4357     PUSHBLOCK(cx, CXt_GIVEN, SP);
4358     PUSHGIVEN(cx);
4359
4360     RETURN;
4361 }
4362
4363 PP(pp_leavegiven)
4364 {
4365     dSP;
4366     PERL_CONTEXT *cx;
4367     I32 gimme;
4368     SV **newsp;
4369     PMOP *newpm;
4370     PERL_UNUSED_CONTEXT;
4371
4372     POPBLOCK(cx,newpm);
4373     assert(CxTYPE(cx) == CXt_GIVEN);
4374
4375     SP = leave_common(newsp, SP, newsp, gimme,
4376                                SVs_PADTMP|SVs_TEMP, FALSE);
4377     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4378
4379     LEAVE_with_name("given");
4380     RETURN;
4381 }
4382
4383 /* Helper routines used by pp_smartmatch */
4384 STATIC PMOP *
4385 S_make_matcher(pTHX_ REGEXP *re)
4386 {
4387     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4388
4389     PERL_ARGS_ASSERT_MAKE_MATCHER;
4390
4391     PM_SETRE(matcher, ReREFCNT_inc(re));
4392
4393     SAVEFREEOP((OP *) matcher);
4394     ENTER_with_name("matcher"); SAVETMPS;
4395     SAVEOP();
4396     return matcher;
4397 }
4398
4399 STATIC bool
4400 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4401 {
4402     dSP;
4403     bool result;
4404
4405     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4406
4407     PL_op = (OP *) matcher;
4408     XPUSHs(sv);
4409     PUTBACK;
4410     (void) Perl_pp_match(aTHX);
4411     SPAGAIN;
4412     result = SvTRUEx(POPs);
4413     PUTBACK;
4414
4415     return result;
4416 }
4417
4418 STATIC void
4419 S_destroy_matcher(pTHX_ PMOP *matcher)
4420 {
4421     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4422     PERL_UNUSED_ARG(matcher);
4423
4424     FREETMPS;
4425     LEAVE_with_name("matcher");
4426 }
4427
4428 /* Do a smart match */
4429 PP(pp_smartmatch)
4430 {
4431     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4432     return do_smartmatch(NULL, NULL, 0);
4433 }
4434
4435 /* This version of do_smartmatch() implements the
4436  * table of smart matches that is found in perlsyn.
4437  */
4438 STATIC OP *
4439 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4440 {
4441     dSP;
4442
4443     bool object_on_left = FALSE;
4444     SV *e = TOPs;       /* e is for 'expression' */
4445     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4446
4447     /* Take care only to invoke mg_get() once for each argument.
4448      * Currently we do this by copying the SV if it's magical. */
4449     if (d) {
4450         if (!copied && SvGMAGICAL(d))
4451             d = sv_mortalcopy(d);
4452     }
4453     else
4454         d = &PL_sv_undef;
4455
4456     assert(e);
4457     if (SvGMAGICAL(e))
4458         e = sv_mortalcopy(e);
4459
4460     /* First of all, handle overload magic of the rightmost argument */
4461     if (SvAMAGIC(e)) {
4462         SV * tmpsv;
4463         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4464         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4465
4466         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4467         if (tmpsv) {
4468             SPAGAIN;
4469             (void)POPs;
4470             SETs(tmpsv);
4471             RETURN;
4472         }
4473         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4474     }
4475
4476     SP -= 2;    /* Pop the values */
4477     PUTBACK;
4478
4479     /* ~~ undef */
4480     if (!SvOK(e)) {
4481         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4482         if (SvOK(d))
4483             RETPUSHNO;
4484         else
4485             RETPUSHYES;
4486     }
4487
4488     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4489         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4490         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4491     }
4492     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4493         object_on_left = TRUE;
4494
4495     /* ~~ sub */
4496     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4497         I32 c;
4498         if (object_on_left) {
4499             goto sm_any_sub;&