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