pp_ctl.c

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