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 = CX_CUR();
 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
 289             CX_LEAVE_SCOPE(cx);
 290             CX_POPSUBST(cx);
 291             CX_POP(cx);
 292
 293             PERL_ASYNC_CHECK();
 294             RETURNOP(pm->op_next);
 295             NOT_REACHED; /* NOTREACHED */
 296         }
 297         cx->sb_iters = saviters;
 298     }
 299     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 300         m = s;
 301         s = orig;
 302         assert(!RX_SUBOFFSET(rx));
 303         cx->sb_orig = orig = RX_SUBBEG(rx);
 304         s = orig + (m - s);
 305         cx->sb_strend = s + (cx->sb_strend - m);
 306     }
 307     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 308     if (m > s) {
 309         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 310             sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
 311         else
 312             sv_catpvn_nomg(dstr, s, m-s);
 313     }
 314     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 315     { /* Update the pos() information. */
 316         SV * const sv
 317             = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
 318         MAGIC *mg;
 319
 320         /* the string being matched against may no longer be a string,
 321          * e.g. $_=0; s/.../$_++/ge */
 322
 323         if (!SvPOK(sv))
 324             SvPV_force_nomg_nolen(sv);
 325
 326         if (!(mg = mg_find_mglob(sv))) {
 327             mg = sv_magicext_mglob(sv);
 328         }
 329         MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
 330     }
 331     if (old != rx)
 332         (void)ReREFCNT_inc(rx);
 333     /* update the taint state of various various variables in preparation
 334      * for calling the code block.
 335      * See "how taint works" above pp_subst() */
 336     if (TAINTING_get) {
 337         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 338             cx->sb_rxtainted |= SUBST_TAINT_PAT;
 339
 340         if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 341             ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 342                             == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 343         )
 344             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 345
 346         if (cx->sb_iters > 1 && (cx->sb_rxtainted &
 347                         (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
 348             SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
 349                          ? cx->sb_dstr : cx->sb_targ);
 350         TAINT_NOT;
 351     }
 352     rxres_save(&cx->sb_rxres, rx);
 353     PL_curpm = pm;
 354     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 355 }
 356
 357 void
 358 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 359 {
 360     UV *p = (UV*)*rsp;
 361     U32 i;
 362
 363     PERL_ARGS_ASSERT_RXRES_SAVE;
 364     PERL_UNUSED_CONTEXT;
 365
 366     if (!p || p[1] < RX_NPARENS(rx)) {
 367 #ifdef PERL_ANY_COW
 368         i = 7 + (RX_NPARENS(rx)+1) * 2;
 369 #else
 370         i = 6 + (RX_NPARENS(rx)+1) * 2;
 371 #endif
 372         if (!p)
 373             Newx(p, i, UV);
 374         else
 375             Renew(p, i, UV);
 376         *rsp = (void*)p;
 377     }
 378
 379     /* what (if anything) to free on croak */
 380     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 381     RX_MATCH_COPIED_off(rx);
 382     *p++ = RX_NPARENS(rx);
 383
 384 #ifdef PERL_ANY_COW
 385     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 386     RX_SAVED_COPY(rx) = NULL;
 387 #endif
 388
 389     *p++ = PTR2UV(RX_SUBBEG(rx));
 390     *p++ = (UV)RX_SUBLEN(rx);
 391     *p++ = (UV)RX_SUBOFFSET(rx);
 392     *p++ = (UV)RX_SUBCOFFSET(rx);
 393     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 394         *p++ = (UV)RX_OFFS(rx)[i].start;
 395         *p++ = (UV)RX_OFFS(rx)[i].end;
 396     }
 397 }
 398
 399 static void
 400 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 401 {
 402     UV *p = (UV*)*rsp;
 403     U32 i;
 404
 405     PERL_ARGS_ASSERT_RXRES_RESTORE;
 406     PERL_UNUSED_CONTEXT;
 407
 408     RX_MATCH_COPY_FREE(rx);
 409     RX_MATCH_COPIED_set(rx, *p);
 410     *p++ = 0;
 411     RX_NPARENS(rx) = *p++;
 412
 413 #ifdef PERL_ANY_COW
 414     if (RX_SAVED_COPY(rx))
 415         SvREFCNT_dec (RX_SAVED_COPY(rx));
 416     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 417     *p++ = 0;
 418 #endif
 419
 420     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 421     RX_SUBLEN(rx) = (I32)(*p++);
 422     RX_SUBOFFSET(rx) = (I32)*p++;
 423     RX_SUBCOFFSET(rx) = (I32)*p++;
 424     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 425         RX_OFFS(rx)[i].start = (I32)(*p++);
 426         RX_OFFS(rx)[i].end = (I32)(*p++);
 427     }
 428 }
 429
 430 static void
 431 S_rxres_free(pTHX_ void **rsp)
 432 {
 433     UV * const p = (UV*)*rsp;
 434
 435     PERL_ARGS_ASSERT_RXRES_FREE;
 436     PERL_UNUSED_CONTEXT;
 437
 438     if (p) {
 439         void *tmp = INT2PTR(char*,*p);
 440 #ifdef PERL_POISON
 441 #ifdef PERL_ANY_COW
 442         U32 i = 9 + p[1] * 2;
 443 #else
 444         U32 i = 8 + p[1] * 2;
 445 #endif
 446 #endif
 447
 448 #ifdef PERL_ANY_COW
 449         SvREFCNT_dec (INT2PTR(SV*,p[2]));
 450 #endif
 451 #ifdef PERL_POISON
 452         PoisonFree(p, i, sizeof(UV));
 453 #endif
 454
 455         Safefree(tmp);
 456         Safefree(p);
 457         *rsp = NULL;
 458     }
 459 }
 460
 461 #define FORM_NUM_BLANK (1<<30)
 462 #define FORM_NUM_POINT (1<<29)
 463
 464 PP(pp_formline)
 465 {
 466     dSP; dMARK; dORIGMARK;
 467     SV * const tmpForm = *++MARK;
 468     SV *formsv;             /* contains text of original format */
 469     U32 *fpc;       /* format ops program counter */
 470     char *t;        /* current append position in target string */
 471     const char *f;          /* current position in format string */
 472     I32 arg;
 473     SV *sv = NULL; /* current item */
 474     const char *item = NULL;/* string value of current item */
 475     I32 itemsize  = 0;      /* length (chars) of item, possibly truncated */
 476     I32 itembytes = 0;      /* as itemsize, but length in bytes */
 477     I32 fieldsize = 0;      /* width of current field */
 478     I32 lines = 0;          /* number of lines that have been output */
 479     bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
 480     const char *chophere = NULL; /* where to chop current item */
 481     STRLEN linemark = 0;    /* pos of start of line in output */
 482     NV value;
 483     bool gotsome = FALSE;   /* seen at least one non-blank item on this line */
 484     STRLEN len;             /* length of current sv */
 485     STRLEN linemax;         /* estimate of output size in bytes */
 486     bool item_is_utf8 = FALSE;
 487     bool targ_is_utf8 = FALSE;
 488     const char *fmt;
 489     MAGIC *mg = NULL;
 490     U8 *source;             /* source of bytes to append */
 491     STRLEN to_copy;         /* how may bytes to append */
 492     char trans;             /* what chars to translate */
 493
 494     mg = doparseform(tmpForm);
 495
 496     fpc = (U32*)mg->mg_ptr;
 497     /* the actual string the format was compiled from.
 498      * with overload etc, this may not match tmpForm */
 499     formsv = mg->mg_obj;
 500
 501
 502     SvPV_force(PL_formtarget, len);
 503     if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
 504         SvTAINTED_on(PL_formtarget);
 505     if (DO_UTF8(PL_formtarget))
 506         targ_is_utf8 = TRUE;
 507     linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
 508     t = SvGROW(PL_formtarget, len + linemax + 1);
 509     /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
 510     t += len;
 511     f = SvPV_const(formsv, len);
 512
 513     for (;;) {
 514         DEBUG_f( {
 515             const char *name = "???";
 516             arg = -1;
 517             switch (*fpc) {
 518             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 519             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 520             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 521             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 522             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 523
 524             case FF_CHECKNL:    name = "CHECKNL";       break;
 525             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 526             case FF_SPACE:      name = "SPACE";         break;
 527             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 528             case FF_ITEM:       name = "ITEM";          break;
 529             case FF_CHOP:       name = "CHOP";          break;
 530             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 531             case FF_NEWLINE:    name = "NEWLINE";       break;
 532             case FF_MORE:       name = "MORE";          break;
 533             case FF_LINEMARK:   name = "LINEMARK";      break;
 534             case FF_END:        name = "END";           break;
 535             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 536             case FF_LINESNGL:   name = "LINESNGL";      break;
 537             }
 538             if (arg >= 0)
 539                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 540             else
 541                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 542         } );
 543         switch (*fpc++) {
 544         case FF_LINEMARK: /* start (or end) of a line */
 545             linemark = t - SvPVX(PL_formtarget);
 546             lines++;
 547             gotsome = FALSE;
 548             break;
 549
 550         case FF_LITERAL: /* append <arg> literal chars */
 551             to_copy = *fpc++;
 552             source = (U8 *)f;
 553             f += to_copy;
 554             trans = '~';
 555             item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
 556             goto append;
 557
 558         case FF_SKIP: /* skip <arg> chars in format */
 559             f += *fpc++;
 560             break;
 561
 562         case FF_FETCH: /* get next item and set field size to <arg> */
 563             arg = *fpc++;
 564             f += arg;
 565             fieldsize = arg;
 566
 567             if (MARK < SP)
 568                 sv = *++MARK;
 569             else {
 570                 sv = &PL_sv_no;
 571                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 572             }
 573             if (SvTAINTED(sv))
 574                 SvTAINTED_on(PL_formtarget);
 575             break;
 576
 577         case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
 578             {
 579                 const char *s = item = SvPV_const(sv, len);
 580                 const char *send = s + len;
 581
 582                 itemsize = 0;
 583                 item_is_utf8 = DO_UTF8(sv);
 584                 while (s < send) {
 585                     if (!isCNTRL(*s))
 586                         gotsome = TRUE;
 587                     else if (*s == '\n')
 588                         break;
 589
 590                     if (item_is_utf8)
 591                         s += UTF8SKIP(s);
 592                     else
 593                         s++;
 594                     itemsize++;
 595                     if (itemsize == fieldsize)
 596                         break;
 597                 }
 598                 itembytes = s - item;
 599                 chophere = s;
 600                 break;
 601             }
 602
 603         case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
 604             {
 605                 const char *s = item = SvPV_const(sv, len);
 606                 const char *send = s + len;
 607                 I32 size = 0;
 608
 609                 chophere = NULL;
 610                 item_is_utf8 = DO_UTF8(sv);
 611                 while (s < send) {
 612                     /* look for a legal split position */
 613                     if (isSPACE(*s)) {
 614                         if (*s == '\r') {
 615                             chophere = s;
 616                             itemsize = size;
 617                             break;
 618                         }
 619                         if (chopspace) {
 620                             /* provisional split point */
 621                             chophere = s;
 622                             itemsize = size;
 623                         }
 624                         /* we delay testing fieldsize until after we've
 625                          * processed the possible split char directly
 626                          * following the last field char; so if fieldsize=3
 627                          * and item="a b cdef", we consume "a b", not "a".
 628                          * Ditto further down.
 629                          */
 630                         if (size == fieldsize)
 631                             break;
 632                     }
 633                     else {
 634                         if (strchr(PL_chopset, *s)) {
 635                             /* provisional split point */
 636                             /* for a non-space split char, we include
 637                              * the split char; hence the '+1' */
 638                             chophere = s + 1;
 639                             itemsize = size;
 640                         }
 641                         if (size == fieldsize)
 642                             break;
 643                         if (!isCNTRL(*s))
 644                             gotsome = TRUE;
 645                     }
 646
 647                     if (item_is_utf8)
 648                         s += UTF8SKIP(s);
 649                     else
 650                         s++;
 651                     size++;
 652                 }
 653                 if (!chophere || s == send) {
 654                     chophere = s;
 655                     itemsize = size;
 656                 }
 657                 itembytes = chophere - item;
 658
 659                 break;
 660             }
 661
 662         case FF_SPACE: /* append padding space (diff of field, item size) */
 663             arg = fieldsize - itemsize;
 664             if (arg) {
 665                 fieldsize -= arg;
 666                 while (arg-- > 0)
 667                     *t++ = ' ';
 668             }
 669             break;
 670
 671         case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
 672             arg = fieldsize - itemsize;
 673             if (arg) {
 674                 arg /= 2;
 675                 fieldsize -= arg;
 676                 while (arg-- > 0)
 677                     *t++ = ' ';
 678             }
 679             break;
 680
 681         case FF_ITEM: /* append a text item, while blanking ctrl chars */
 682             to_copy = itembytes;
 683             source = (U8 *)item;
 684             trans = 1;
 685             goto append;
 686
 687         case FF_CHOP: /* (for ^*) chop the current item */
 688             if (sv != &PL_sv_no) {
 689                 const char *s = chophere;
 690                 if (chopspace) {
 691                     while (isSPACE(*s))
 692                         s++;
 693                 }
 694                 if (SvPOKp(sv))
 695                     sv_chop(sv,s);
 696                 else
 697                     /* tied, overloaded or similar strangeness.
 698                      * Do it the hard way */
 699                     sv_setpvn(sv, s, len - (s-item));
 700                 SvSETMAGIC(sv);
 701                 break;
 702             }
 703
 704         case FF_LINESNGL: /* process ^*  */
 705             chopspace = 0;
 706             /* FALLTHROUGH */
 707
 708         case FF_LINEGLOB: /* process @*  */
 709             {
 710                 const bool oneline = fpc[-1] == FF_LINESNGL;
 711                 const char *s = item = SvPV_const(sv, len);
 712                 const char *const send = s + len;
 713
 714                 item_is_utf8 = DO_UTF8(sv);
 715                 chophere = s + len;
 716                 if (!len)
 717                     break;
 718                 trans = 0;
 719                 gotsome = TRUE;
 720                 source = (U8 *) s;
 721                 to_copy = len;
 722                 while (s < send) {
 723                     if (*s++ == '\n') {
 724                         if (oneline) {
 725                             to_copy = s - item - 1;
 726                             chophere = s;
 727                             break;
 728                         } else {
 729                             if (s == send) {
 730                                 to_copy--;
 731                             } else
 732                                 lines++;
 733                         }
 734                     }
 735                 }
 736             }
 737
 738         append:
 739             /* append to_copy bytes from source to PL_formstring.
 740              * item_is_utf8 implies source is utf8.
 741              * if trans, translate certain characters during the copy */
 742             {
 743                 U8 *tmp = NULL;
 744                 STRLEN grow = 0;
 745
 746                 SvCUR_set(PL_formtarget,
 747                           t - SvPVX_const(PL_formtarget));
 748
 749                 if (targ_is_utf8 && !item_is_utf8) {
 750                     source = tmp = bytes_to_utf8(source, &to_copy);
 751                 } else {
 752                     if (item_is_utf8 && !targ_is_utf8) {
 753                         U8 *s;
 754                         /* Upgrade targ to UTF8, and then we reduce it to
 755                            a problem we have a simple solution for.
 756                            Don't need get magic.  */
 757                         sv_utf8_upgrade_nomg(PL_formtarget);
 758                         targ_is_utf8 = TRUE;
 759                         /* re-calculate linemark */
 760                         s = (U8*)SvPVX(PL_formtarget);
 761                         /* the bytes we initially allocated to append the
 762                          * whole line may have been gobbled up during the
 763                          * upgrade, so allocate a whole new line's worth
 764                          * for safety */
 765                         grow = linemax;
 766                         while (linemark--)
 767                             s += UTF8SKIP(s);
 768                         linemark = s - (U8*)SvPVX(PL_formtarget);
 769                     }
 770                     /* Easy. They agree.  */
 771                     assert (item_is_utf8 == targ_is_utf8);
 772                 }
 773                 if (!trans)
 774                     /* @* and ^* are the only things that can exceed
 775                      * the linemax, so grow by the output size, plus
 776                      * a whole new form's worth in case of any further
 777                      * output */
 778                     grow = linemax + to_copy;
 779                 if (grow)
 780                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
 781                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 782
 783                 Copy(source, t, to_copy, char);
 784                 if (trans) {
 785                     /* blank out ~ or control chars, depending on trans.
 786                      * works on bytes not chars, so relies on not
 787                      * matching utf8 continuation bytes */
 788                     U8 *s = (U8*)t;
 789                     U8 *send = s + to_copy;
 790                     while (s < send) {
 791                         const int ch = *s;
 792                         if (trans == '~' ? (ch == '~') : isCNTRL(ch))
 793                             *s = ' ';
 794                         s++;
 795                     }
 796                 }
 797
 798                 t += to_copy;
 799                 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 800                 if (tmp)
 801                     Safefree(tmp);
 802                 break;
 803             }
 804
 805         case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
 806             arg = *fpc++;
 807             fmt = (const char *)
 808                 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
 809             goto ff_dec;
 810
 811         case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
 812             arg = *fpc++;
 813             fmt = (const char *)
 814                 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
 815         ff_dec:
 816             /* If the field is marked with ^ and the value is undefined,
 817                blank it out. */
 818             if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
 819                 arg = fieldsize;
 820                 while (arg--)
 821                     *t++ = ' ';
 822                 break;
 823             }
 824             gotsome = TRUE;
 825             value = SvNV(sv);
 826             /* overflow evidence */
 827             if (num_overflow(value, fieldsize, arg)) {
 828                 arg = fieldsize;
 829                 while (arg--)
 830                     *t++ = '#';
 831                 break;
 832             }
 833             /* Formats aren't yet marked for locales, so assume "yes". */
 834             {
 835                 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
 836                 int len;
 837                 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
 838                 STORE_LC_NUMERIC_SET_TO_NEEDED();
 839                 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
 840 #ifdef USE_QUADMATH
 841                 {
 842                     const char* qfmt = quadmath_format_single(fmt);
 843                     int len;
 844                     if (!qfmt)
 845                         Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
 846                     len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
 847                     if (len == -1)
 848                         Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
 849                     if (qfmt != fmt)
 850                         Safefree(fmt);
 851                 }
 852 #else
 853                 /* we generate fmt ourselves so it is safe */
 854                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
 855                 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
 856                 GCC_DIAG_RESTORE;
 857 #endif
 858                 PERL_MY_SNPRINTF_POST_GUARD(len, max);
 859                 RESTORE_LC_NUMERIC();
 860             }
 861             t += fieldsize;
 862             break;
 863
 864         case FF_NEWLINE: /* delete trailing spaces, then append \n */
 865             f++;
 866             while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
 867             t++;
 868             *t++ = '\n';
 869             break;
 870
 871         case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
 872             arg = *fpc++;
 873             if (gotsome) {
 874                 if (arg) {              /* repeat until fields exhausted? */
 875                     fpc--;
 876                     goto end;
 877                 }
 878             }
 879             else {
 880                 t = SvPVX(PL_formtarget) + linemark;
 881                 lines--;
 882             }
 883             break;
 884
 885         case FF_MORE: /* replace long end of string with '...' */
 886             {
 887                 const char *s = chophere;
 888                 const char *send = item + len;
 889                 if (chopspace) {
 890                     while (isSPACE(*s) && (s < send))
 891                         s++;
 892                 }
 893                 if (s < send) {
 894                     char *s1;
 895                     arg = fieldsize - itemsize;
 896                     if (arg) {
 897                         fieldsize -= arg;
 898                         while (arg-- > 0)
 899                             *t++ = ' ';
 900                     }
 901                     s1 = t - 3;
 902                     if (strnEQ(s1,"   ",3)) {
 903                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 904                             s1--;
 905                     }
 906                     *s1++ = '.';
 907                     *s1++ = '.';
 908                     *s1++ = '.';
 909                 }
 910                 break;
 911             }
 912
 913         case FF_END: /* tidy up, then return */
 914         end:
 915             assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
 916             *t = '\0';
 917             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 918             if (targ_is_utf8)
 919                 SvUTF8_on(PL_formtarget);
 920             FmLINES(PL_formtarget) += lines;
 921             SP = ORIGMARK;
 922             if (fpc[-1] == FF_BLANK)
 923                 RETURNOP(cLISTOP->op_first);
 924             else
 925                 RETPUSHYES;
 926         }
 927     }
 928 }
 929
 930 /* also used for: pp_mapstart() */
 931 PP(pp_grepstart)
 932 {
 933     dSP;
 934     SV *src;
 935
 936     if (PL_stack_base + TOPMARK == SP) {
 937         (void)POPMARK;
 938         if (GIMME_V == G_SCALAR)
 939             mXPUSHi(0);
 940         RETURNOP(PL_op->op_next->op_next);
 941     }
 942     PL_stack_sp = PL_stack_base + TOPMARK + 1;
 943     Perl_pp_pushmark(aTHX);                             /* push dst */
 944     Perl_pp_pushmark(aTHX);                             /* push src */
 945     ENTER_with_name("grep");                                    /* enter outer scope */
 946
 947     SAVETMPS;
 948     SAVE_DEFSV;
 949     ENTER_with_name("grep_item");                                       /* enter inner scope */
 950     SAVEVPTR(PL_curpm);
 951
 952     src = PL_stack_base[TOPMARK];
 953     if (SvPADTMP(src)) {
 954         src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
 955         PL_tmps_floor++;
 956     }
 957     SvTEMP_off(src);
 958     DEFSV_set(src);
 959
 960     PUTBACK;
 961     if (PL_op->op_type == OP_MAPSTART)
 962         Perl_pp_pushmark(aTHX);                 /* push top */
 963     return ((LOGOP*)PL_op->op_next)->op_other;
 964 }
 965
 966 PP(pp_mapwhile)
 967 {
 968     dSP;
 969     const U8 gimme = GIMME_V;
 970     I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
 971     I32 count;
 972     I32 shift;
 973     SV** src;
 974     SV** dst;
 975
 976     /* first, move source pointer to the next item in the source list */
 977     ++PL_markstack_ptr[-1];
 978
 979     /* if there are new items, push them into the destination list */
 980     if (items && gimme != G_VOID) {
 981         /* might need to make room back there first */
 982         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 983             /* XXX this implementation is very pessimal because the stack
 984              * is repeatedly extended for every set of items.  Is possible
 985              * to do this without any stack extension or copying at all
 986              * by maintaining a separate list over which the map iterates
 987              * (like foreach does). --gsar */
 988
 989             /* everything in the stack after the destination list moves
 990              * towards the end the stack by the amount of room needed */
 991             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 992
 993             /* items to shift up (accounting for the moved source pointer) */
 994             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 995
 996             /* This optimization is by Ben Tilly and it does
 997              * things differently from what Sarathy (gsar)
 998              * is describing.  The downside of this optimization is
 999              * that leaves "holes" (uninitialized and hopefully unused areas)
1000              * to the Perl stack, but on the other hand this
1001              * shouldn't be a problem.  If Sarathy's idea gets
1002              * implemented, this optimization should become
1003              * irrelevant.  --jhi */
1004             if (shift < count)
1005                 shift = count; /* Avoid shifting too often --Ben Tilly */
1006
1007             EXTEND(SP,shift);
1008             src = SP;
1009             dst = (SP += shift);
1010             PL_markstack_ptr[-1] += shift;
1011             *PL_markstack_ptr += shift;
1012             while (count--)
1013                 *dst-- = *src--;
1014         }
1015         /* copy the new items down to the destination list */
1016         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1017         if (gimme == G_ARRAY) {
1018             /* add returned items to the collection (making mortal copies
1019              * if necessary), then clear the current temps stack frame
1020              * *except* for those items. We do this splicing the items
1021              * into the start of the tmps frame (so some items may be on
1022              * the tmps stack twice), then moving PL_tmps_floor above
1023              * them, then freeing the frame. That way, the only tmps that
1024              * accumulate over iterations are the return values for map.
1025              * We have to do to this way so that everything gets correctly
1026              * freed if we die during the map.
1027              */
1028             I32 tmpsbase;
1029             I32 i = items;
1030             /* make space for the slice */
1031             EXTEND_MORTAL(items);
1032             tmpsbase = PL_tmps_floor + 1;
1033             Move(PL_tmps_stack + tmpsbase,
1034                  PL_tmps_stack + tmpsbase + items,
1035                  PL_tmps_ix - PL_tmps_floor,
1036                  SV*);
1037             PL_tmps_ix += items;
1038
1039             while (i-- > 0) {
1040                 SV *sv = POPs;
1041                 if (!SvTEMP(sv))
1042                     sv = sv_mortalcopy(sv);
1043                 *dst-- = sv;
1044                 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1045             }
1046             /* clear the stack frame except for the items */
1047             PL_tmps_floor += items;
1048             FREETMPS;
1049             /* FREETMPS may have cleared the TEMP flag on some of the items */
1050             i = items;
1051             while (i-- > 0)
1052                 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1053         }
1054         else {
1055             /* scalar context: we don't care about which values map returns
1056              * (we use undef here). And so we certainly don't want to do mortal
1057              * copies of meaningless values. */
1058             while (items-- > 0) {
1059                 (void)POPs;
1060                 *dst-- = &PL_sv_undef;
1061             }
1062             FREETMPS;
1063         }
1064     }
1065     else {
1066         FREETMPS;
1067     }
1068     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1069
1070     /* All done yet? */
1071     if (PL_markstack_ptr[-1] > TOPMARK) {
1072
1073         (void)POPMARK;                          /* pop top */
1074         LEAVE_with_name("grep");                                        /* exit outer scope */
1075         (void)POPMARK;                          /* pop src */
1076         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1077         (void)POPMARK;                          /* pop dst */
1078         SP = PL_stack_base + POPMARK;           /* pop original mark */
1079         if (gimme == G_SCALAR) {
1080                 dTARGET;
1081                 XPUSHi(items);
1082         }
1083         else if (gimme == G_ARRAY)
1084             SP += items;
1085         RETURN;
1086     }
1087     else {
1088         SV *src;
1089
1090         ENTER_with_name("grep_item");                                   /* enter inner scope */
1091         SAVEVPTR(PL_curpm);
1092
1093         /* set $_ to the new source item */
1094         src = PL_stack_base[PL_markstack_ptr[-1]];
1095         if (SvPADTMP(src)) {
1096             src = sv_mortalcopy(src);
1097         }
1098         SvTEMP_off(src);
1099         DEFSV_set(src);
1100
1101         RETURNOP(cLOGOP->op_other);
1102     }
1103 }
1104
1105 /* Range stuff. */
1106
1107 PP(pp_range)
1108 {
1109     if (GIMME_V == G_ARRAY)
1110         return NORMAL;
1111     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1112         return cLOGOP->op_other;
1113     else
1114         return NORMAL;
1115 }
1116
1117 PP(pp_flip)
1118 {
1119     dSP;
1120
1121     if (GIMME_V == G_ARRAY) {
1122         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1123     }
1124     else {
1125         dTOPss;
1126         SV * const targ = PAD_SV(PL_op->op_targ);
1127         int flip = 0;
1128
1129         if (PL_op->op_private & OPpFLIP_LINENUM) {
1130             if (GvIO(PL_last_in_gv)) {
1131                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1132             }
1133             else {
1134                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1135                 if (gv && GvSV(gv))
1136                     flip = SvIV(sv) == SvIV(GvSV(gv));
1137             }
1138         } else {
1139             flip = SvTRUE(sv);
1140         }
1141         if (flip) {
1142             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1143             if (PL_op->op_flags & OPf_SPECIAL) {
1144                 sv_setiv(targ, 1);
1145                 SETs(targ);
1146                 RETURN;
1147             }
1148             else {
1149                 sv_setiv(targ, 0);
1150                 SP--;
1151                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1152             }
1153         }
1154         sv_setpvs(TARG, "");
1155         SETs(targ);
1156         RETURN;
1157     }
1158 }
1159
1160 /* This code tries to decide if "$left .. $right" should use the
1161    magical string increment, or if the range is numeric (we make
1162    an exception for .."0" [#18165]). AMS 20021031. */
1163
1164 #define RANGE_IS_NUMERIC(left,right) ( \
1165         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1166         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1167         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1168           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1169          && (!SvOK(right) || looks_like_number(right))))
1170
1171 PP(pp_flop)
1172 {
1173     dSP;
1174
1175     if (GIMME_V == G_ARRAY) {
1176         dPOPPOPssrl;
1177
1178         SvGETMAGIC(left);
1179         SvGETMAGIC(right);
1180
1181         if (RANGE_IS_NUMERIC(left,right)) {
1182             IV i, j, n;
1183             if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1184                 (SvOK(right) && (SvIOK(right)
1185                                  ? SvIsUV(right) && SvUV(right) > IV_MAX
1186                                  : SvNV_nomg(right) > IV_MAX)))
1187                 DIE(aTHX_ "Range iterator outside integer range");
1188             i = SvIV_nomg(left);
1189             j = SvIV_nomg(right);
1190             if (j >= i) {
1191                 /* Dance carefully around signed max. */
1192                 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1193                 if (!overflow) {
1194                     n = j - i + 1;
1195                     /* The wraparound of signed integers is undefined
1196                      * behavior, but here we aim for count >=1, and
1197                      * negative count is just wrong. */
1198                     if (n < 1
1199 #if IVSIZE > Size_t_size
1200                         || n > SSize_t_MAX
1201 #endif
1202                         )
1203                         overflow = TRUE;
1204                 }
1205                 if (overflow)
1206                     Perl_croak(aTHX_ "Out of memory during list extend");
1207                 EXTEND_MORTAL(n);
1208                 EXTEND(SP, n);
1209             }
1210             else
1211                 n = 0;
1212             while (n--) {
1213                 SV * const sv = sv_2mortal(newSViv(i));
1214                 PUSHs(sv);
1215                 if (n) /* avoid incrementing above IV_MAX */
1216                     i++;
1217             }
1218         }
1219         else {
1220             STRLEN len, llen;
1221             const char * const lpv = SvPV_nomg_const(left, llen);
1222             const char * const tmps = SvPV_nomg_const(right, len);
1223
1224             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1225             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1226                 XPUSHs(sv);
1227                 if (strEQ(SvPVX_const(sv),tmps))
1228                     break;
1229                 sv = sv_2mortal(newSVsv(sv));
1230                 sv_inc(sv);
1231             }
1232         }
1233     }
1234     else {
1235         dTOPss;
1236         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1237         int flop = 0;
1238         sv_inc(targ);
1239
1240         if (PL_op->op_private & OPpFLIP_LINENUM) {
1241             if (GvIO(PL_last_in_gv)) {
1242                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1243             }
1244             else {
1245                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1246                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1247             }
1248         }
1249         else {
1250             flop = SvTRUE(sv);
1251         }
1252
1253         if (flop) {
1254             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1255             sv_catpvs(targ, "E0");
1256         }
1257         SETs(targ);
1258     }
1259
1260     RETURN;
1261 }
1262
1263 /* Control. */
1264
1265 static const char * const context_name[] = {
1266     "pseudo-block",
1267     NULL, /* CXt_WHEN never actually needs "block" */
1268     NULL, /* CXt_BLOCK never actually needs "block" */
1269     NULL, /* CXt_GIVEN never actually needs "block" */
1270     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1271     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1272     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1273     NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1274     NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1275     "subroutine",
1276     "format",
1277     "eval",
1278     "substitution",
1279 };
1280
1281 STATIC I32
1282 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1283 {
1284     I32 i;
1285
1286     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1287
1288     for (i = cxstack_ix; i >= 0; i--) {
1289         const PERL_CONTEXT * const cx = &cxstack[i];
1290         switch (CxTYPE(cx)) {
1291         case CXt_SUBST:
1292         case CXt_SUB:
1293         case CXt_FORMAT:
1294         case CXt_EVAL:
1295         case CXt_NULL:
1296             /* diag_listed_as: Exiting subroutine via %s */
1297             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1298                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1299             if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1300                 return -1;
1301             break;
1302         case CXt_LOOP_PLAIN:
1303         case CXt_LOOP_LAZYIV:
1304         case CXt_LOOP_LAZYSV:
1305         case CXt_LOOP_LIST:
1306         case CXt_LOOP_ARY:
1307           {
1308             STRLEN cx_label_len = 0;
1309             U32 cx_label_flags = 0;
1310             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1311             if (!cx_label || !(
1312                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1313                         (flags & SVf_UTF8)
1314                             ? (bytes_cmp_utf8(
1315                                         (const U8*)cx_label, cx_label_len,
1316                                         (const U8*)label, len) == 0)
1317                             : (bytes_cmp_utf8(
1318                                         (const U8*)label, len,
1319                                         (const U8*)cx_label, cx_label_len) == 0)
1320                     : (len == cx_label_len && ((cx_label == label)
1321                                     || memEQ(cx_label, label, len))) )) {
1322                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1323                         (long)i, cx_label));
1324                 continue;
1325             }
1326             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1327             return i;
1328           }
1329         }
1330     }
1331     return i;
1332 }
1333
1334
1335
1336 U8
1337 Perl_dowantarray(pTHX)
1338 {
1339     const U8 gimme = block_gimme();
1340     return (gimme == G_VOID) ? G_SCALAR : gimme;
1341 }
1342
1343 U8
1344 Perl_block_gimme(pTHX)
1345 {
1346     const I32 cxix = dopoptosub(cxstack_ix);
1347     U8 gimme;
1348     if (cxix < 0)
1349         return G_VOID;
1350
1351     gimme = (cxstack[cxix].blk_gimme & G_WANT);
1352     if (!gimme)
1353         Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1354     return gimme;
1355 }
1356
1357
1358 I32
1359 Perl_is_lvalue_sub(pTHX)
1360 {
1361     const I32 cxix = dopoptosub(cxstack_ix);
1362     assert(cxix >= 0);  /* We should only be called from inside subs */
1363
1364     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1365         return CxLVAL(cxstack + cxix);
1366     else
1367         return 0;
1368 }
1369
1370 /* only used by cx_pushsub() */
1371 I32
1372 Perl_was_lvalue_sub(pTHX)
1373 {
1374     const I32 cxix = dopoptosub(cxstack_ix-1);
1375     assert(cxix >= 0);  /* We should only be called from inside subs */
1376
1377     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1378         return CxLVAL(cxstack + cxix);
1379     else
1380         return 0;
1381 }
1382
1383 STATIC I32
1384 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1385 {
1386     I32 i;
1387
1388     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1389 #ifndef DEBUGGING
1390     PERL_UNUSED_CONTEXT;
1391 #endif
1392
1393     for (i = startingblock; i >= 0; i--) {
1394         const PERL_CONTEXT * const cx = &cxstk[i];
1395         switch (CxTYPE(cx)) {
1396         default:
1397             continue;
1398         case CXt_SUB:
1399             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1400              * twice; the first for the normal foo() call, and the second
1401              * for a faked up re-entry into the sub to execute the
1402              * code block. Hide this faked entry from the world. */
1403             if (cx->cx_type & CXp_SUB_RE_FAKE)
1404                 continue;
1405             /* FALLTHROUGH */
1406         case CXt_EVAL:
1407         case CXt_FORMAT:
1408             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1409             return i;
1410         }
1411     }
1412     return i;
1413 }
1414
1415 STATIC I32
1416 S_dopoptoeval(pTHX_ I32 startingblock)
1417 {
1418     I32 i;
1419     for (i = startingblock; i >= 0; i--) {
1420         const PERL_CONTEXT *cx = &cxstack[i];
1421         switch (CxTYPE(cx)) {
1422         default:
1423             continue;
1424         case CXt_EVAL:
1425             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1426             return i;
1427         }
1428     }
1429     return i;
1430 }
1431
1432 STATIC I32
1433 S_dopoptoloop(pTHX_ I32 startingblock)
1434 {
1435     I32 i;
1436     for (i = startingblock; i >= 0; i--) {
1437         const PERL_CONTEXT * const cx = &cxstack[i];
1438         switch (CxTYPE(cx)) {
1439         case CXt_SUBST:
1440         case CXt_SUB:
1441         case CXt_FORMAT:
1442         case CXt_EVAL:
1443         case CXt_NULL:
1444             /* diag_listed_as: Exiting subroutine via %s */
1445             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1446                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1447             if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1448                 return -1;
1449             break;
1450         case CXt_LOOP_PLAIN:
1451         case CXt_LOOP_LAZYIV:
1452         case CXt_LOOP_LAZYSV:
1453         case CXt_LOOP_LIST:
1454         case CXt_LOOP_ARY:
1455             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1456             return i;
1457         }
1458     }
1459     return i;
1460 }
1461
1462 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1463
1464 STATIC I32
1465 S_dopoptogivenfor(pTHX_ I32 startingblock)
1466 {
1467     I32 i;
1468     for (i = startingblock; i >= 0; i--) {
1469         const PERL_CONTEXT *cx = &cxstack[i];
1470         switch (CxTYPE(cx)) {
1471         default:
1472             continue;
1473         case CXt_GIVEN:
1474             DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1475             return i;
1476         case CXt_LOOP_PLAIN:
1477             assert(!(cx->cx_type & CXp_FOR_DEF));
1478             break;
1479         case CXt_LOOP_LAZYIV:
1480         case CXt_LOOP_LAZYSV:
1481         case CXt_LOOP_LIST:
1482         case CXt_LOOP_ARY:
1483             if (cx->cx_type & CXp_FOR_DEF) {
1484                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1485                 return i;
1486             }
1487         }
1488     }
1489     return i;
1490 }
1491
1492 STATIC I32
1493 S_dopoptowhen(pTHX_ I32 startingblock)
1494 {
1495     I32 i;
1496     for (i = startingblock; i >= 0; i--) {
1497         const PERL_CONTEXT *cx = &cxstack[i];
1498         switch (CxTYPE(cx)) {
1499         default:
1500             continue;
1501         case CXt_WHEN:
1502             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1503             return i;
1504         }
1505     }
1506     return i;
1507 }
1508
1509 /* dounwind(): pop all contexts above (but not including) cxix.
1510  * Note that it clears the savestack frame associated with each popped
1511  * context entry, but doesn't free any temps.
1512  * It does a cx_popblock() of the last frame that it pops, and leaves
1513  * cxstack_ix equal to cxix.
1514  */
1515
1516 void
1517 Perl_dounwind(pTHX_ I32 cxix)
1518 {
1519     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1520         return;
1521
1522     while (cxstack_ix > cxix) {
1523         PERL_CONTEXT *cx = CX_CUR();
1524
1525         CX_DEBUG(cx, "UNWIND");
1526         /* Note: we don't need to restore the base context info till the end. */
1527
1528         CX_LEAVE_SCOPE(cx);
1529
1530         switch (CxTYPE(cx)) {
1531         case CXt_SUBST:
1532             CX_POPSUBST(cx);
1533             break;
1534         case CXt_SUB:
1535             cx_popsub(cx);
1536             break;
1537         case CXt_EVAL:
1538             cx_popeval(cx);
1539             break;
1540         case CXt_LOOP_PLAIN:
1541         case CXt_LOOP_LAZYIV:
1542         case CXt_LOOP_LAZYSV:
1543         case CXt_LOOP_LIST:
1544         case CXt_LOOP_ARY:
1545             cx_poploop(cx);
1546             break;
1547         case CXt_WHEN:
1548             cx_popwhen(cx);
1549             break;
1550         case CXt_GIVEN:
1551             cx_popgiven(cx);
1552             break;
1553         case CXt_BLOCK:
1554         case CXt_NULL:
1555             /* these two don't have a POPFOO() */
1556             break;
1557         case CXt_FORMAT:
1558             cx_popformat(cx);
1559             break;
1560         }
1561         if (cxstack_ix == cxix + 1) {
1562             cx_popblock(cx);
1563         }
1564         cxstack_ix--;
1565     }
1566
1567 }
1568
1569 void
1570 Perl_qerror(pTHX_ SV *err)
1571 {
1572     PERL_ARGS_ASSERT_QERROR;
1573
1574     if (PL_in_eval) {
1575         if (PL_in_eval & EVAL_KEEPERR) {
1576                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1577                                                     SVfARG(err));
1578         }
1579         else
1580             sv_catsv(ERRSV, err);
1581     }
1582     else if (PL_errors)
1583         sv_catsv(PL_errors, err);
1584     else
1585         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1586     if (PL_parser)
1587         ++PL_parser->error_count;
1588 }
1589
1590
1591
1592 /* pop a CXt_EVAL context and in addition, if it was a require then
1593  * based on action:
1594  *     0: do nothing extra;
1595  *     1: undef  $INC{$name}; croak "$name did not return a true value";
1596  *     2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1597  */
1598
1599 static void
1600 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1601 {
1602     SV  *namesv = NULL; /* init to avoid dumb compiler warning */
1603     bool do_croak;
1604
1605     CX_LEAVE_SCOPE(cx);
1606     do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1607     if (do_croak) {
1608         /* keep namesv alive after cx_popeval() */
1609         namesv = cx->blk_eval.old_namesv;
1610         cx->blk_eval.old_namesv = NULL;
1611         sv_2mortal(namesv);
1612     }
1613     cx_popeval(cx);
1614     cx_popblock(cx);
1615     CX_POP(cx);
1616
1617     if (do_croak) {
1618         const char *fmt;
1619         HV *inc_hv = GvHVn(PL_incgv);
1620         I32  klen  = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1621         const char *key = SvPVX_const(namesv);
1622
1623         if (action == 1) {
1624             (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1625             fmt = "%"SVf" did not return a true value";
1626             errsv = namesv;
1627         }
1628         else {
1629             (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1630             fmt = "%"SVf"Compilation failed in require";
1631             if (!errsv)
1632                 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1633         }
1634
1635         Perl_croak(aTHX_ fmt, SVfARG(errsv));
1636     }
1637 }
1638
1639
1640 /* die_unwind(): this is the final destination for the various croak()
1641  * functions. If we're in an eval, unwind the context and other stacks
1642  * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1643  * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1644  * to is a require the exception will be rethrown, as requires don't
1645  * actually trap exceptions.
1646  */
1647
1648 void
1649 Perl_die_unwind(pTHX_ SV *msv)
1650 {
1651     SV *exceptsv = msv;
1652     U8 in_eval = PL_in_eval;
1653     PERL_ARGS_ASSERT_DIE_UNWIND;
1654
1655     if (in_eval) {
1656         I32 cxix;
1657
1658         exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1659
1660         /*
1661          * Historically, perl used to set ERRSV ($@) early in the die
1662          * process and rely on it not getting clobbered during unwinding.
1663          * That sucked, because it was liable to get clobbered, so the
1664          * setting of ERRSV used to emit the exception from eval{} has
1665          * been moved to much later, after unwinding (see just before
1666          * JMPENV_JUMP below).  However, some modules were relying on the
1667          * early setting, by examining $@ during unwinding to use it as
1668          * a flag indicating whether the current unwinding was caused by
1669          * an exception.  It was never a reliable flag for that purpose,
1670          * being totally open to false positives even without actual
1671          * clobberage, but was useful enough for production code to
1672          * semantically rely on it.
1673          *
1674          * We'd like to have a proper introspective interface that
1675          * explicitly describes the reason for whatever unwinding
1676          * operations are currently in progress, so that those modules
1677          * work reliably and $@ isn't further overloaded.  But we don't
1678          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1679          * now *additionally* set here, before unwinding, to serve as the
1680          * (unreliable) flag that it used to.
1681          *
1682          * This behaviour is temporary, and should be removed when a
1683          * proper way to detect exceptional unwinding has been developed.
1684          * As of 2010-12, the authors of modules relying on the hack
1685          * are aware of the issue, because the modules failed on
1686          * perls 5.13.{1..7} which had late setting of $@ without this
1687          * early-setting hack.
1688          */
1689         if (!(in_eval & EVAL_KEEPERR))
1690             sv_setsv_flags(ERRSV, exceptsv,
1691                         (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1692
1693         if (in_eval & EVAL_KEEPERR) {
1694             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1695                            SVfARG(exceptsv));
1696         }
1697
1698         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1699                && PL_curstackinfo->si_prev)
1700         {
1701             dounwind(-1);
1702             POPSTACK;
1703         }
1704
1705         if (cxix >= 0) {
1706             PERL_CONTEXT *cx;
1707             SV **oldsp;
1708             U8 gimme;
1709             JMPENV *restartjmpenv;
1710             OP *restartop;
1711
1712             if (cxix < cxstack_ix)
1713                 dounwind(cxix);
1714
1715             cx = CX_CUR();
1716             assert(CxTYPE(cx) == CXt_EVAL);
1717
1718             /* return false to the caller of eval */
1719             oldsp = PL_stack_base + cx->blk_oldsp;
1720             gimme = cx->blk_gimme;
1721             if (gimme == G_SCALAR)
1722                 *++oldsp = &PL_sv_undef;
1723             PL_stack_sp = oldsp;
1724
1725             restartjmpenv = cx->blk_eval.cur_top_env;
1726             restartop     = cx->blk_eval.retop;
1727             /* Note that unlike pp_entereval, pp_require isn't supposed to
1728              * trap errors. So if we're a require, after we pop the
1729              * CXt_EVAL that pp_require pushed, rethrow the error with
1730              * croak(exceptsv). This is all handled by the call below when
1731              * action == 2.
1732              */
1733             S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1734
1735             if (!(in_eval & EVAL_KEEPERR))
1736                 sv_setsv(ERRSV, exceptsv);
1737             PL_restartjmpenv = restartjmpenv;
1738             PL_restartop = restartop;
1739             JMPENV_JUMP(3);
1740             NOT_REACHED; /* NOTREACHED */
1741         }
1742     }
1743
1744     write_to_stderr(exceptsv);
1745     my_failure_exit();
1746     NOT_REACHED; /* NOTREACHED */
1747 }
1748
1749 PP(pp_xor)
1750 {
1751     dSP; dPOPTOPssrl;
1752     if (SvTRUE(left) != SvTRUE(right))
1753         RETSETYES;
1754     else
1755         RETSETNO;
1756 }
1757
1758 /*
1759
1760 =head1 CV Manipulation Functions
1761
1762 =for apidoc caller_cx
1763
1764 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1765 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1766 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1767 stack frame, so C<caller_cx(0, NULL)> will return information for the
1768 immediately-surrounding Perl code.
1769
1770 This function skips over the automatic calls to C<&DB::sub> made on the
1771 behalf of the debugger.  If the stack frame requested was a sub called by
1772 C<DB::sub>, the return value will be the frame for the call to
1773 C<DB::sub>, since that has the correct line number/etc. for the call
1774 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1775 frame for the sub call itself.
1776
1777 =cut
1778 */
1779
1780 const PERL_CONTEXT *
1781 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1782 {
1783     I32 cxix = dopoptosub(cxstack_ix);
1784     const PERL_CONTEXT *cx;
1785     const PERL_CONTEXT *ccstack = cxstack;
1786     const PERL_SI *top_si = PL_curstackinfo;
1787
1788     for (;;) {
1789         /* we may be in a higher stacklevel, so dig down deeper */
1790         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1791             top_si = top_si->si_prev;
1792             ccstack = top_si->si_cxstack;
1793             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1794         }
1795         if (cxix < 0)
1796             return NULL;
1797         /* caller() should not report the automatic calls to &DB::sub */
1798         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1799                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1800             count++;
1801         if (!count--)
1802             break;
1803         cxix = dopoptosub_at(ccstack, cxix - 1);
1804     }
1805
1806     cx = &ccstack[cxix];
1807     if (dbcxp) *dbcxp = cx;
1808
1809     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1810         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1811         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1812            field below is defined for any cx. */
1813         /* caller() should not report the automatic calls to &DB::sub */
1814         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1815             cx = &ccstack[dbcxix];
1816     }
1817
1818     return cx;
1819 }
1820
1821 PP(pp_caller)
1822 {
1823     dSP;
1824     const PERL_CONTEXT *cx;
1825     const PERL_CONTEXT *dbcx;
1826     U8 gimme = GIMME_V;
1827     const HEK *stash_hek;
1828     I32 count = 0;
1829     bool has_arg = MAXARG && TOPs;
1830     const COP *lcop;
1831
1832     if (MAXARG) {
1833       if (has_arg)
1834         count = POPi;
1835       else (void)POPs;
1836     }
1837
1838     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1839     if (!cx) {
1840         if (gimme != G_ARRAY) {
1841             EXTEND(SP, 1);
1842             RETPUSHUNDEF;
1843         }
1844         RETURN;
1845     }
1846
1847     CX_DEBUG(cx, "CALLER");
1848     assert(CopSTASH(cx->blk_oldcop));
1849     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1850       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1851       : NULL;
1852     if (gimme != G_ARRAY) {
1853         EXTEND(SP, 1);
1854         if (!stash_hek)
1855             PUSHs(&PL_sv_undef);
1856         else {
1857             dTARGET;
1858             sv_sethek(TARG, stash_hek);
1859             PUSHs(TARG);
1860         }
1861         RETURN;
1862     }
1863
1864     EXTEND(SP, 11);
1865
1866     if (!stash_hek)
1867         PUSHs(&PL_sv_undef);
1868     else {
1869         dTARGET;
1870         sv_sethek(TARG, stash_hek);
1871         PUSHTARG;
1872     }
1873     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1874     lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1875                        cx->blk_sub.retop, TRUE);
1876     if (!lcop)
1877         lcop = cx->blk_oldcop;
1878     mPUSHu(CopLINE(lcop));
1879     if (!has_arg)
1880         RETURN;
1881     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1882         /* So is ccstack[dbcxix]. */
1883         if (CvHASGV(dbcx->blk_sub.cv)) {
1884             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1885             PUSHs(boolSV(CxHASARGS(cx)));
1886         }
1887         else {
1888             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1889             PUSHs(boolSV(CxHASARGS(cx)));
1890         }
1891     }
1892     else {
1893         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1894         mPUSHi(0);
1895     }
1896     gimme = cx->blk_gimme;
1897     if (gimme == G_VOID)
1898         PUSHs(&PL_sv_undef);
1899     else
1900         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1901     if (CxTYPE(cx) == CXt_EVAL) {
1902         /* eval STRING */
1903         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1904             SV *cur_text = cx->blk_eval.cur_text;
1905             if (SvCUR(cur_text) >= 2) {
1906                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1907                                      SvUTF8(cur_text)|SVs_TEMP));
1908             }
1909             else {
1910                 /* I think this is will always be "", but be sure */
1911                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1912             }
1913
1914             PUSHs(&PL_sv_no);
1915         }
1916         /* require */
1917         else if (cx->blk_eval.old_namesv) {
1918             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1919             PUSHs(&PL_sv_yes);
1920         }
1921         /* eval BLOCK (try blocks have old_namesv == 0) */
1922         else {
1923             PUSHs(&PL_sv_undef);
1924             PUSHs(&PL_sv_undef);
1925         }
1926     }
1927     else {
1928         PUSHs(&PL_sv_undef);
1929         PUSHs(&PL_sv_undef);
1930     }
1931     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1932         && CopSTASH_eq(PL_curcop, PL_debstash))
1933     {
1934         /* slot 0 of the pad contains the original @_ */
1935         AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1936                             PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1937                                 cx->blk_sub.olddepth+1]))[0]);
1938         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1939
1940         Perl_init_dbargs(aTHX);
1941
1942         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1943             av_extend(PL_dbargs, AvFILLp(ary) + off);
1944         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1945         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1946     }
1947     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1948     {
1949         SV * mask ;
1950         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1951
1952         if  (old_warnings == pWARN_NONE)
1953             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1954         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1955             mask = &PL_sv_undef ;
1956         else if (old_warnings == pWARN_ALL ||
1957                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1958             /* Get the bit mask for $warnings::Bits{all}, because
1959              * it could have been extended by warnings::register */
1960             SV **bits_all;
1961             HV * const bits = get_hv("warnings::Bits", 0);
1962             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1963                 mask = newSVsv(*bits_all);
1964             }
1965             else {
1966                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1967             }
1968         }
1969         else
1970             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1971         mPUSHs(mask);
1972     }
1973
1974     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1975           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1976           : &PL_sv_undef);
1977     RETURN;
1978 }
1979
1980 PP(pp_reset)
1981 {
1982     dSP;
1983     const char * tmps;
1984     STRLEN len = 0;
1985     if (MAXARG < 1 || (!TOPs && !POPs))
1986         tmps = NULL, len = 0;
1987     else
1988         tmps = SvPVx_const(POPs, len);
1989     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1990     PUSHs(&PL_sv_yes);
1991     RETURN;
1992 }
1993
1994 /* like pp_nextstate, but used instead when the debugger is active */
1995
1996 PP(pp_dbstate)
1997 {
1998     PL_curcop = (COP*)PL_op;
1999     TAINT_NOT;          /* Each statement is presumed innocent */
2000     PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2001     FREETMPS;
2002
2003     PERL_ASYNC_CHECK();
2004
2005     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2006             || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2007     {
2008         dSP;
2009         PERL_CONTEXT *cx;
2010         const U8 gimme = G_ARRAY;
2011         GV * const gv = PL_DBgv;
2012         CV * cv = NULL;
2013
2014         if (gv && isGV_with_GP(gv))
2015             cv = GvCV(gv);
2016
2017         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2018             DIE(aTHX_ "No DB::DB routine defined");
2019
2020         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2021             /* don't do recursive DB::DB call */
2022             return NORMAL;
2023
2024         if (CvISXSUB(cv)) {
2025             ENTER;
2026             SAVEI32(PL_debug);
2027             PL_debug = 0;
2028             SAVESTACK_POS();
2029             SAVETMPS;
2030             PUSHMARK(SP);
2031             (void)(*CvXSUB(cv))(aTHX_ cv);
2032             FREETMPS;
2033             LEAVE;
2034             return NORMAL;
2035         }
2036         else {
2037             cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2038             cx_pushsub(cx, cv, PL_op->op_next, 0);
2039             /* OP_DBSTATE's op_private holds hint bits rather than
2040              * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2041              * any CxLVAL() flags that have now been mis-calculated */
2042             cx->blk_u16 = 0;
2043
2044             SAVEI32(PL_debug);
2045             PL_debug = 0;
2046             SAVESTACK_POS();
2047             CvDEPTH(cv)++;
2048             if (CvDEPTH(cv) >= 2)
2049                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2050             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2051             RETURNOP(CvSTART(cv));
2052         }
2053     }
2054     else
2055         return NORMAL;
2056 }
2057
2058
2059 PP(pp_enter)
2060 {
2061     U8 gimme = GIMME_V;
2062
2063     (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2064     return NORMAL;
2065 }
2066
2067
2068 PP(pp_leave)
2069 {
2070     PERL_CONTEXT *cx;
2071     SV **oldsp;
2072     U8 gimme;
2073
2074     cx = CX_CUR();
2075     assert(CxTYPE(cx) == CXt_BLOCK);
2076
2077     if (PL_op->op_flags & OPf_SPECIAL)
2078         /* fake block should preserve $1 et al; e.g.  /(...)/ while ...; */
2079         cx->blk_oldpm = PL_curpm;
2080
2081     oldsp = PL_stack_base + cx->blk_oldsp;
2082     gimme = cx->blk_gimme;
2083
2084     if (gimme == G_VOID)
2085         PL_stack_sp = oldsp;
2086     else
2087         leave_adjust_stacks(oldsp, oldsp, gimme,
2088                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2089
2090     CX_LEAVE_SCOPE(cx);
2091     cx_popblock(cx);
2092     CX_POP(cx);
2093
2094     return NORMAL;
2095 }
2096
2097 static bool
2098 S_outside_integer(pTHX_ SV *sv)
2099 {
2100   if (SvOK(sv)) {
2101     const NV nv = SvNV_nomg(sv);
2102     if (Perl_isinfnan(nv))
2103       return TRUE;
2104 #ifdef NV_PRESERVES_UV
2105     if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2106       return TRUE;
2107 #else
2108     if (nv <= (NV)IV_MIN)
2109       return TRUE;
2110     if ((nv > 0) &&
2111         ((nv > (NV)UV_MAX ||
2112           SvUV_nomg(sv) > (UV)IV_MAX)))
2113       return TRUE;
2114 #endif
2115   }
2116   return FALSE;
2117 }
2118
2119 PP(pp_enteriter)
2120 {
2121     dSP; dMARK;
2122     PERL_CONTEXT *cx;
2123     const U8 gimme = GIMME_V;
2124     void *itervarp; /* GV or pad slot of the iteration variable */
2125     SV   *itersave; /* the old var in the iterator var slot */
2126     U8 cxflags = 0;
2127
2128     if (PL_op->op_targ) {                        /* "my" variable */
2129         itervarp = &PAD_SVl(PL_op->op_targ);
2130         itersave = *(SV**)itervarp;
2131         assert(itersave);
2132         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2133             /* the SV currently in the pad slot is never live during
2134              * iteration (the slot is always aliased to one of the items)
2135              * so it's always stale */
2136             SvPADSTALE_on(itersave);
2137         }
2138         SvREFCNT_inc_simple_void_NN(itersave);
2139         cxflags = CXp_FOR_PAD;
2140     }
2141     else {
2142         SV * const sv = POPs;
2143         itervarp = (void *)sv;
2144         if (LIKELY(isGV(sv))) {         /* symbol table variable */
2145             itersave = GvSV(sv);
2146             SvREFCNT_inc_simple_void(itersave);
2147             cxflags = CXp_FOR_GV;
2148             if (PL_op->op_private & OPpITER_DEF)
2149                 cxflags |= CXp_FOR_DEF;
2150         }
2151         else {                          /* LV ref: for \$foo (...) */
2152             assert(SvTYPE(sv) == SVt_PVMG);
2153             assert(SvMAGIC(sv));
2154             assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2155             itersave = NULL;
2156             cxflags = CXp_FOR_LVREF;
2157         }
2158     }
2159     /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2160     assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2161
2162     /* Note that this context is initially set as CXt_NULL. Further on
2163      * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2164      * there mustn't be anything in the blk_loop substruct that requires
2165      * freeing or undoing, in case we die in the meantime. And vice-versa.
2166      */
2167     cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2168     cx_pushloop_for(cx, itervarp, itersave);
2169
2170     if (PL_op->op_flags & OPf_STACKED) {
2171         /* OPf_STACKED implies either a single array: for(@), with a
2172          * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2173          * the stack */
2174         SV *maybe_ary = POPs;
2175         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2176             /* range */
2177             dPOPss;
2178             SV * const right = maybe_ary;
2179             if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2180                 DIE(aTHX_ "Assigned value is not a reference");
2181             SvGETMAGIC(sv);
2182             SvGETMAGIC(right);
2183             if (RANGE_IS_NUMERIC(sv,right)) {
2184                 cx->cx_type |= CXt_LOOP_LAZYIV;
2185                 if (S_outside_integer(aTHX_ sv) ||
2186                     S_outside_integer(aTHX_ right))
2187                     DIE(aTHX_ "Range iterator outside integer range");
2188                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2189                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2190             }
2191             else {
2192                 cx->cx_type |= CXt_LOOP_LAZYSV;
2193                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2194                 cx->blk_loop.state_u.lazysv.end = right;
2195                 SvREFCNT_inc_simple_void_NN(right);
2196                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2197                 /* This will do the upgrade to SVt_PV, and warn if the value
2198                    is uninitialised.  */
2199                 (void) SvPV_nolen_const(right);
2200                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2201                    to replace !SvOK() with a pointer to "".  */
2202                 if (!SvOK(right)) {
2203                     SvREFCNT_dec(right);
2204                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2205                 }
2206             }
2207         }
2208         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2209             /* for (@array) {} */
2210             cx->cx_type |= CXt_LOOP_ARY;
2211             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2212             SvREFCNT_inc_simple_void_NN(maybe_ary);
2213             cx->blk_loop.state_u.ary.ix =
2214                 (PL_op->op_private & OPpITER_REVERSED) ?
2215                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2216                 -1;
2217         }
2218         /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2219     }
2220     else { /* iterating over items on the stack */
2221         cx->cx_type |= CXt_LOOP_LIST;
2222         cx->blk_oldsp = SP - PL_stack_base;
2223         cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2224         cx->blk_loop.state_u.stack.ix =
2225             (PL_op->op_private & OPpITER_REVERSED)
2226                 ? cx->blk_oldsp + 1
2227                 : cx->blk_loop.state_u.stack.basesp;
2228         /* pre-extend stack so pp_iter doesn't have to check every time
2229          * it pushes yes/no */
2230         EXTEND(SP, 1);
2231     }
2232
2233     RETURN;
2234 }
2235
2236 PP(pp_enterloop)
2237 {
2238     PERL_CONTEXT *cx;
2239     const U8 gimme = GIMME_V;
2240
2241     cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2242     cx_pushloop_plain(cx);
2243     return NORMAL;
2244 }
2245
2246
2247 PP(pp_leaveloop)
2248 {
2249     PERL_CONTEXT *cx;
2250     U8 gimme;
2251     SV **oldsp;
2252     SV **mark;
2253
2254     cx = CX_CUR();
2255     assert(CxTYPE_is_LOOP(cx));
2256     mark = PL_stack_base + cx->blk_oldsp;
2257     oldsp = CxTYPE(cx) == CXt_LOOP_LIST
2258                 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2259                 : mark;
2260     gimme = cx->blk_gimme;
2261
2262     if (gimme == G_VOID)
2263         PL_stack_sp = oldsp;
2264     else
2265         leave_adjust_stacks(MARK, oldsp, gimme,
2266                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2267
2268     CX_LEAVE_SCOPE(cx);
2269     cx_poploop(cx);     /* Stack values are safe: release loop vars ... */
2270     cx_popblock(cx);
2271     CX_POP(cx);
2272
2273     return NORMAL;
2274 }
2275
2276
2277 /* This duplicates most of pp_leavesub, but with additional code to handle
2278  * return args in lvalue context. It was forked from pp_leavesub to
2279  * avoid slowing down that function any further.
2280  *
2281  * Any changes made to this function may need to be copied to pp_leavesub
2282  * and vice-versa.
2283  *
2284  * also tail-called by pp_return
2285  */
2286
2287 PP(pp_leavesublv)
2288 {
2289     U8 gimme;
2290     PERL_CONTEXT *cx;
2291     SV **oldsp;
2292     OP *retop;
2293
2294     cx = CX_CUR();
2295     assert(CxTYPE(cx) == CXt_SUB);
2296
2297     if (CxMULTICALL(cx)) {
2298         /* entry zero of a stack is always PL_sv_undef, which
2299          * simplifies converting a '()' return into undef in scalar context */
2300         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2301         return 0;
2302     }
2303
2304     gimme = cx->blk_gimme;
2305     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2306
2307     if (gimme == G_VOID)
2308         PL_stack_sp = oldsp;
2309     else {
2310         U8   lval    = CxLVAL(cx);
2311         bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2312         const char *what = NULL;
2313
2314         if (gimme == G_SCALAR) {
2315             if (is_lval) {
2316                 /* check for bad return arg */
2317                 if (oldsp < PL_stack_sp) {
2318                     SV *sv = *PL_stack_sp;
2319                     if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2320                         what =
2321                             SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2322                             : "a readonly value" : "a temporary";
2323                     }
2324                     else goto ok;
2325                 }
2326                 else {
2327                     /* sub:lvalue{} will take us here. */
2328                     what = "undef";
2329                 }
2330               croak:
2331                 Perl_croak(aTHX_
2332                           "Can't return %s from lvalue subroutine", what);
2333             }
2334
2335           ok:
2336             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2337
2338             if (lval & OPpDEREF) {
2339                 /* lval_sub()->{...} and similar */
2340                 dSP;
2341                 SvGETMAGIC(TOPs);
2342                 if (!SvOK(TOPs)) {
2343                     TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2344                 }
2345                 PUTBACK;
2346             }
2347         }
2348         else {
2349             assert(gimme == G_ARRAY);
2350             assert (!(lval & OPpDEREF));
2351
2352             if (is_lval) {
2353                 /* scan for bad return args */
2354                 SV **p;
2355                 for (p = PL_stack_sp; p > oldsp; p--) {
2356                     SV *sv = *p;
2357                     /* the PL_sv_undef exception is to allow things like
2358                      * this to work, where PL_sv_undef acts as 'skip'
2359                      * placeholder on the LHS of list assigns:
2360                      *    sub foo :lvalue { undef }
2361                      *    ($a, undef, foo(), $b) = 1..4;
2362                      */
2363                     if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2364                     {
2365                         /* Might be flattened array after $#array =  */
2366                         what = SvREADONLY(sv)
2367                                 ? "a readonly value" : "a temporary";
2368                         goto croak;
2369                     }
2370                 }
2371             }
2372
2373             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2374         }
2375     }
2376
2377     CX_LEAVE_SCOPE(cx);
2378     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
2379     cx_popblock(cx);
2380     retop =  cx->blk_sub.retop;
2381     CX_POP(cx);
2382
2383     return retop;
2384 }
2385
2386
2387 PP(pp_return)
2388 {
2389     dSP; dMARK;
2390     PERL_CONTEXT *cx;
2391     const I32 cxix = dopoptosub(cxstack_ix);
2392
2393     assert(cxstack_ix >= 0);
2394     if (cxix < cxstack_ix) {
2395         if (cxix < 0) {
2396             if (!(       PL_curstackinfo->si_type == PERLSI_SORT
2397                   || (   PL_curstackinfo->si_type == PERLSI_MULTICALL
2398                       && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2399                  )
2400             )
2401                 DIE(aTHX_ "Can't return outside a subroutine");
2402             /* We must be in:
2403              *  a sort block, which is a CXt_NULL not a CXt_SUB;
2404              *  or a /(?{...})/ block.
2405              * Handle specially. */
2406             assert(CxTYPE(&cxstack[0]) == CXt_NULL
2407                     || (   CxTYPE(&cxstack[0]) == CXt_SUB
2408                         && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2409             if (cxstack_ix > 0) {
2410                 /* See comment below about context popping. Since we know
2411                  * we're scalar and not lvalue, we can preserve the return
2412                  * value in a simpler fashion than there. */
2413                 SV *sv = *SP;
2414                 assert(cxstack[0].blk_gimme == G_SCALAR);
2415                 if (   (sp != PL_stack_base)
2416                     && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2417                 )
2418                     *SP = sv_mortalcopy(sv);
2419                 dounwind(0);
2420             }
2421             /* caller responsible for popping cxstack[0] */
2422             return 0;
2423         }
2424
2425         /* There are contexts that need popping. Doing this may free the
2426          * return value(s), so preserve them first: e.g. popping the plain
2427          * loop here would free $x:
2428          *     sub f {  { my $x = 1; return $x } }
2429          * We may also need to shift the args down; for example,
2430          *    for (1,2) { return 3,4 }
2431          * leaves 1,2,3,4 on the stack. Both these actions will be done by
2432          * leave_adjust_stacks(), along with freeing any temps. Note that
2433          * whoever we tail-call (e.g. pp_leaveeval) will also call
2434          * leave_adjust_stacks(); however, the second call is likely to
2435          * just see a bunch of SvTEMPs with a ref count of 1, and so just
2436          * pass them through, rather than copying them again. So this
2437          * isn't as inefficient as it sounds.
2438          */
2439         cx = &cxstack[cxix];
2440         PUTBACK;
2441         if (cx->blk_gimme != G_VOID)
2442             leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2443                     cx->blk_gimme,
2444                     CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2445                         ? 3 : 0);
2446         SPAGAIN;
2447         dounwind(cxix);
2448         cx = &cxstack[cxix]; /* CX stack may have been realloced */
2449     }
2450     else {
2451         /* Like in the branch above, we need to handle any extra junk on
2452          * the stack. But because we're not also popping extra contexts, we
2453          * don't have to worry about prematurely freeing args. So we just
2454          * need to do the bare minimum to handle junk, and leave the main
2455          * arg processing in the function we tail call, e.g. pp_leavesub.
2456          * In list context we have to splice out the junk; in scalar
2457          * context we can leave as-is (pp_leavesub will later return the
2458          * top stack element). But for an  empty arg list, e.g.
2459          *    for (1,2) { return }
2460          * we need to set sp = oldsp so that pp_leavesub knows to push
2461          * &PL_sv_undef onto the stack.
2462          */
2463         SV **oldsp;
2464         cx = &cxstack[cxix];
2465         oldsp = PL_stack_base + cx->blk_oldsp;
2466         if (oldsp != MARK) {
2467             SSize_t nargs = SP - MARK;
2468             if (nargs) {
2469                 if (cx->blk_gimme == G_ARRAY) {
2470                     /* shift return args to base of call stack frame */
2471                     Move(MARK + 1, oldsp + 1, nargs, SV*);
2472                     PL_stack_sp  = oldsp + nargs;
2473                 }
2474             }
2475             else
2476                 PL_stack_sp  = oldsp;
2477         }
2478     }
2479
2480     /* fall through to a normal exit */
2481     switch (CxTYPE(cx)) {
2482     case CXt_EVAL:
2483         return CxTRYBLOCK(cx)
2484             ? Perl_pp_leavetry(aTHX)
2485             : Perl_pp_leaveeval(aTHX);
2486     case CXt_SUB:
2487         return CvLVALUE(cx->blk_sub.cv)
2488             ? Perl_pp_leavesublv(aTHX)
2489             : Perl_pp_leavesub(aTHX);
2490     case CXt_FORMAT:
2491         return Perl_pp_leavewrite(aTHX);
2492     default:
2493         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2494     }
2495 }
2496
2497 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2498
2499 static PERL_CONTEXT *
2500 S_unwind_loop(pTHX)
2501 {
2502     I32 cxix;
2503     if (PL_op->op_flags & OPf_SPECIAL) {
2504         cxix = dopoptoloop(cxstack_ix);
2505         if (cxix < 0)
2506             /* diag_listed_as: Can't "last" outside a loop block */
2507             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2508                 OP_NAME(PL_op));
2509     }
2510     else {
2511         dSP;
2512         STRLEN label_len;
2513         const char * const label =
2514             PL_op->op_flags & OPf_STACKED
2515                 ? SvPV(TOPs,label_len)
2516                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2517         const U32 label_flags =
2518             PL_op->op_flags & OPf_STACKED
2519                 ? SvUTF8(POPs)
2520                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2521         PUTBACK;
2522         cxix = dopoptolabel(label, label_len, label_flags);
2523         if (cxix < 0)
2524             /* diag_listed_as: Label not found for "last %s" */
2525             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2526                                        OP_NAME(PL_op),
2527                                        SVfARG(PL_op->op_flags & OPf_STACKED
2528                                               && !SvGMAGICAL(TOPp1s)
2529                                               ? TOPp1s
2530                                               : newSVpvn_flags(label,
2531                                                     label_len,
2532                                                     label_flags | SVs_TEMP)));
2533     }
2534     if (cxix < cxstack_ix)
2535         dounwind(cxix);
2536     return &cxstack[cxix];
2537 }
2538
2539
2540 PP(pp_last)
2541 {
2542     PERL_CONTEXT *cx;
2543     OP* nextop;
2544
2545     cx = S_unwind_loop(aTHX);
2546
2547     assert(CxTYPE_is_LOOP(cx));
2548     PL_stack_sp = PL_stack_base
2549                 + (CxTYPE(cx) == CXt_LOOP_LIST
2550                     ?  cx->blk_loop.state_u.stack.basesp
2551                     : cx->blk_oldsp
2552                 );
2553
2554     TAINT_NOT;
2555
2556     /* Stack values are safe: */
2557     CX_LEAVE_SCOPE(cx);
2558     cx_poploop(cx);     /* release loop vars ... */
2559     cx_popblock(cx);
2560     nextop = cx->blk_loop.my_op->op_lastop->op_next;
2561     CX_POP(cx);
2562
2563     return nextop;
2564 }
2565
2566 PP(pp_next)
2567 {
2568     PERL_CONTEXT *cx;
2569
2570     /* if not a bare 'next' in the main scope, search for it */
2571     cx = CX_CUR();
2572     if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2573         cx = S_unwind_loop(aTHX);
2574
2575     cx_topblock(cx);
2576     PL_curcop = cx->blk_oldcop;
2577     PERL_ASYNC_CHECK();
2578     return (cx)->blk_loop.my_op->op_nextop;
2579 }
2580
2581 PP(pp_redo)
2582 {
2583     PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2584     OP* redo_op = cx->blk_loop.my_op->op_redoop;
2585
2586     if (redo_op->op_type == OP_ENTER) {
2587         /* pop one less context to avoid $x being freed in while (my $x..) */
2588         cxstack_ix++;
2589         cx = CX_CUR();
2590         assert(CxTYPE(cx) == CXt_BLOCK);
2591         redo_op = redo_op->op_next;
2592     }
2593
2594     FREETMPS;
2595     CX_LEAVE_SCOPE(cx);
2596     cx_topblock(cx);
2597     PL_curcop = cx->blk_oldcop;
2598     PERL_ASYNC_CHECK();
2599     return redo_op;
2600 }
2601
2602 STATIC OP *
2603 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2604 {
2605     OP **ops = opstack;
2606     static const char* const too_deep = "Target of goto is too deeply nested";
2607
2608     PERL_ARGS_ASSERT_DOFINDLABEL;
2609
2610     if (ops >= oplimit)
2611         Perl_croak(aTHX_ "%s", too_deep);
2612     if (o->op_type == OP_LEAVE ||
2613         o->op_type == OP_SCOPE ||
2614         o->op_type == OP_LEAVELOOP ||
2615         o->op_type == OP_LEAVESUB ||
2616         o->op_type == OP_LEAVETRY)
2617     {
2618         *ops++ = cUNOPo->op_first;
2619         if (ops >= oplimit)
2620             Perl_croak(aTHX_ "%s", too_deep);
2621     }
2622     *ops = 0;
2623     if (o->op_flags & OPf_KIDS) {
2624         OP *kid;
2625         /* First try all the kids at this level, since that's likeliest. */
2626         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2627             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2628                 STRLEN kid_label_len;
2629                 U32 kid_label_flags;
2630                 const char *kid_label = CopLABEL_len_flags(kCOP,
2631                                                     &kid_label_len, &kid_label_flags);
2632                 if (kid_label && (
2633                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2634                         (flags & SVf_UTF8)
2635                             ? (bytes_cmp_utf8(
2636                                         (const U8*)kid_label, kid_label_len,
2637                                         (const U8*)label, len) == 0)
2638                             : (bytes_cmp_utf8(
2639                                         (const U8*)label, len,
2640                                         (const U8*)kid_label, kid_label_len) == 0)
2641                     : ( len == kid_label_len && ((kid_label == label)
2642                                     || memEQ(kid_label, label, len)))))
2643                     return kid;
2644             }
2645         }
2646         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2647             if (kid == PL_lastgotoprobe)
2648                 continue;
2649             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2650                 if (ops == opstack)
2651                     *ops++ = kid;
2652                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2653                          ops[-1]->op_type == OP_DBSTATE)
2654                     ops[-1] = kid;
2655                 else
2656                     *ops++ = kid;
2657             }
2658             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2659                 return o;
2660         }
2661     }
2662     *ops = 0;
2663     return 0;
2664 }
2665
2666
2667 /* also used for: pp_dump() */
2668
2669 PP(pp_goto)
2670 {
2671     dVAR; dSP;
2672     OP *retop = NULL;
2673     I32 ix;
2674     PERL_CONTEXT *cx;
2675 #define GOTO_DEPTH 64
2676     OP *enterops[GOTO_DEPTH];
2677     const char *label = NULL;
2678     STRLEN label_len = 0;
2679     U32 label_flags = 0;
2680     const bool do_dump = (PL_op->op_type == OP_DUMP);
2681     static const char* const must_have_label = "goto must have label";
2682
2683     if (PL_op->op_flags & OPf_STACKED) {
2684         /* goto EXPR  or  goto &foo */
2685
2686         SV * const sv = POPs;
2687         SvGETMAGIC(sv);
2688
2689         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2690             /* This egregious kludge implements goto &subroutine */
2691             I32 cxix;
2692             PERL_CONTEXT *cx;
2693             CV *cv = MUTABLE_CV(SvRV(sv));
2694             AV *arg = GvAV(PL_defgv);
2695
2696             while (!CvROOT(cv) && !CvXSUB(cv)) {
2697                 const GV * const gv = CvGV(cv);
2698                 if (gv) {
2699                     GV *autogv;
2700                     SV *tmpstr;
2701                     /* autoloaded stub? */
2702                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2703                         continue;
2704                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2705                                           GvNAMELEN(gv),
2706                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2707                     if (autogv && (cv = GvCV(autogv)))
2708                         continue;
2709                     tmpstr = sv_newmortal();
2710                     gv_efullname3(tmpstr, gv, NULL);
2711                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2712                 }
2713                 DIE(aTHX_ "Goto undefined subroutine");
2714             }
2715
2716             cxix = dopoptosub(cxstack_ix);
2717             if (cxix < 0) {
2718                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2719             }
2720             cx  = &cxstack[cxix];
2721             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2722             if (CxTYPE(cx) == CXt_EVAL) {
2723                 if (CxREALEVAL(cx))
2724                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2725                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2726                 else
2727                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2728                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2729             }
2730             else if (CxMULTICALL(cx))
2731                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2732
2733             /* First do some returnish stuff. */
2734
2735             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2736             FREETMPS;
2737             if (cxix < cxstack_ix) {
2738                 dounwind(cxix);
2739             }
2740             cx = CX_CUR();
2741             cx_topblock(cx);
2742             SPAGAIN;
2743
2744             /* protect @_ during save stack unwind. */
2745             if (arg)
2746                 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2747
2748             assert(PL_scopestack_ix == cx->blk_oldscopesp);
2749             CX_LEAVE_SCOPE(cx);
2750
2751             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2752                 /* this is part of cx_popsub_args() */
2753                 AV* av = MUTABLE_AV(PAD_SVl(0));
2754                 assert(AvARRAY(MUTABLE_AV(
2755                     PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2756                             CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2757
2758                 /* we are going to donate the current @_ from the old sub
2759                  * to the new sub. This first part of the donation puts a
2760                  * new empty AV in the pad[0] slot of the old sub,
2761                  * unless pad[0] and @_ differ (e.g. if the old sub did
2762                  * local *_ = []); in which case clear the old pad[0]
2763                  * array in the usual way */
2764                 if (av == arg || AvREAL(av))
2765                     clear_defarray(av, av == arg);
2766                 else CLEAR_ARGARRAY(av);
2767             }
2768
2769             /* don't restore PL_comppad here. It won't be needed if the
2770              * sub we're going to is non-XS, but restoring it early then
2771              * croaking (e.g. the "Goto undefined subroutine" below)
2772              * means the CX block gets processed again in dounwind,
2773              * but this time with the wrong PL_comppad */
2774
2775             /* A destructor called during LEAVE_SCOPE could have undefined
2776              * our precious cv.  See bug #99850. */
2777             if (!CvROOT(cv) && !CvXSUB(cv)) {
2778                 const GV * const gv = CvGV(cv);
2779                 if (gv) {
2780                     SV * const tmpstr = sv_newmortal();
2781                     gv_efullname3(tmpstr, gv, NULL);
2782                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2783                                SVfARG(tmpstr));
2784                 }
2785                 DIE(aTHX_ "Goto undefined subroutine");
2786             }
2787
2788             if (CxTYPE(cx) == CXt_SUB) {
2789                 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2790                 SvREFCNT_dec_NN(cx->blk_sub.cv);
2791             }
2792
2793             /* Now do some callish stuff. */
2794             if (CvISXSUB(cv)) {
2795                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2796                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2797                 SV** mark;
2798
2799                 ENTER;
2800                 SAVETMPS;
2801                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2802
2803                 /* put GvAV(defgv) back onto stack */
2804                 if (items) {
2805                     EXTEND(SP, items+1); /* @_ could have been extended. */
2806                 }
2807                 mark = SP;
2808                 if (items) {
2809                     SSize_t index;
2810                     bool r = cBOOL(AvREAL(arg));
2811                     for (index=0; index<items; index++)
2812                     {
2813                         SV *sv;
2814                         if (m) {
2815                             SV ** const svp = av_fetch(arg, index, 0);
2816                             sv = svp ? *svp : NULL;
2817                         }
2818                         else sv = AvARRAY(arg)[index];
2819                         SP[index+1] = sv
2820                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2821                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2822                     }
2823                 }
2824                 SP += items;
2825                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2826                     /* Restore old @_ */
2827                     CX_POP_SAVEARRAY(cx);
2828                 }
2829
2830                 retop = cx->blk_sub.retop;
2831                 PL_comppad = cx->blk_sub.prevcomppad;
2832                 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2833
2834                 /* XS subs don't have a CXt_SUB, so pop it;
2835                  * this is a cx_popblock(), less all the stuff we already did
2836                  * for cx_topblock() earlier */
2837                 PL_curcop = cx->blk_oldcop;
2838                 CX_POP(cx);
2839
2840                 /* Push a mark for the start of arglist */
2841                 PUSHMARK(mark);
2842                 PUTBACK;
2843                 (void)(*CvXSUB(cv))(aTHX_ cv);
2844                 LEAVE;
2845                 goto _return;
2846             }
2847             else {
2848                 PADLIST * const padlist = CvPADLIST(cv);
2849
2850                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2851
2852                 /* partial unrolled cx_pushsub(): */
2853
2854                 cx->blk_sub.cv = cv;
2855                 cx->blk_sub.olddepth = CvDEPTH(cv);
2856
2857                 CvDEPTH(cv)++;
2858                 SvREFCNT_inc_simple_void_NN(cv);
2859                 if (CvDEPTH(cv) > 1) {
2860                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2861                         sub_crush_depth(cv);
2862                     pad_push(padlist, CvDEPTH(cv));
2863                 }
2864                 PL_curcop = cx->blk_oldcop;
2865                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2866                 if (CxHASARGS(cx))
2867                 {
2868                     /* second half of donating @_ from the old sub to the
2869                      * new sub: abandon the original pad[0] AV in the
2870                      * new sub, and replace it with the donated @_.
2871                      * pad[0] takes ownership of the extra refcount
2872                      * we gave arg earlier */
2873                     if (arg) {
2874                         SvREFCNT_dec(PAD_SVl(0));
2875                         PAD_SVl(0) = (SV *)arg;
2876                         SvREFCNT_inc_simple_void_NN(arg);
2877                     }
2878
2879                     /* GvAV(PL_defgv) might have been modified on scope
2880                        exit, so point it at arg again. */
2881                     if (arg != GvAV(PL_defgv)) {
2882                         AV * const av = GvAV(PL_defgv);
2883                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2884                         SvREFCNT_dec(av);
2885                     }
2886                 }
2887
2888                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2889                     Perl_get_db_sub(aTHX_ NULL, cv);
2890                     if (PERLDB_GOTO) {
2891                         CV * const gotocv = get_cvs("DB::goto", 0);
2892                         if (gotocv) {
2893                             PUSHMARK( PL_stack_sp );
2894                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2895                             PL_stack_sp--;
2896                         }
2897                     }
2898                 }
2899                 retop = CvSTART(cv);
2900                 goto putback_return;
2901             }
2902         }
2903         else {
2904             /* goto EXPR */
2905             label       = SvPV_nomg_const(sv, label_len);
2906             label_flags = SvUTF8(sv);
2907         }
2908     }
2909     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2910         /* goto LABEL  or  dump LABEL */
2911         label       = cPVOP->op_pv;
2912         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2913         label_len   = strlen(label);
2914     }
2915     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2916
2917     PERL_ASYNC_CHECK();
2918
2919     if (label_len) {
2920         OP *gotoprobe = NULL;
2921         bool leaving_eval = FALSE;
2922         bool in_block = FALSE;
2923         PERL_CONTEXT *last_eval_cx = NULL;
2924
2925         /* find label */
2926
2927         PL_lastgotoprobe = NULL;
2928         *enterops = 0;
2929         for (ix = cxstack_ix; ix >= 0; ix--) {
2930             cx = &cxstack[ix];
2931             switch (CxTYPE(cx)) {
2932             case CXt_EVAL:
2933                 leaving_eval = TRUE;
2934                 if (!CxTRYBLOCK(cx)) {
2935                     gotoprobe = (last_eval_cx ?
2936                                 last_eval_cx->blk_eval.old_eval_root :
2937                                 PL_eval_root);
2938                     last_eval_cx = cx;
2939                     break;
2940                 }
2941                 /* else fall through */
2942             case CXt_LOOP_PLAIN:
2943             case CXt_LOOP_LAZYIV:
2944             case CXt_LOOP_LAZYSV:
2945             case CXt_LOOP_LIST:
2946             case CXt_LOOP_ARY:
2947             case CXt_GIVEN:
2948             case CXt_WHEN:
2949                 gotoprobe = OpSIBLING(cx->blk_oldcop);
2950                 break;
2951             case CXt_SUBST:
2952                 continue;
2953             case CXt_BLOCK:
2954                 if (ix) {
2955                     gotoprobe = OpSIBLING(cx->blk_oldcop);
2956                     in_block = TRUE;
2957                 } else
2958                     gotoprobe = PL_main_root;
2959                 break;
2960             case CXt_SUB:
2961                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2962                     gotoprobe = CvROOT(cx->blk_sub.cv);
2963                     break;
2964                 }
2965                 /* FALLTHROUGH */
2966             case CXt_FORMAT:
2967             case CXt_NULL:
2968                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2969             default:
2970                 if (ix)
2971                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2972                         CxTYPE(cx), (long) ix);
2973                 gotoprobe = PL_main_root;
2974                 break;
2975             }
2976             if (gotoprobe) {
2977                 OP *sibl1, *sibl2;
2978
2979                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2980                                     enterops, enterops + GOTO_DEPTH);
2981                 if (retop)
2982                     break;
2983                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2984                      sibl1->op_type == OP_UNSTACK &&
2985                      (sibl2 = OpSIBLING(sibl1)))
2986                 {
2987                     retop = dofindlabel(sibl2,
2988                                         label, label_len, label_flags, enterops,
2989                                         enterops + GOTO_DEPTH);
2990                     if (retop)
2991                         break;
2992                 }
2993             }
2994             PL_lastgotoprobe = gotoprobe;
2995         }
2996         if (!retop)
2997             DIE(aTHX_ "Can't find label %"UTF8f,
2998                        UTF8fARG(label_flags, label_len, label));
2999
3000         /* if we're leaving an eval, check before we pop any frames
3001            that we're not going to punt, otherwise the error
3002            won't be caught */
3003
3004         if (leaving_eval && *enterops && enterops[1]) {
3005             I32 i;
3006             for (i = 1; enterops[i]; i++)
3007                 if (enterops[i]->op_type == OP_ENTERITER)
3008                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3009         }
3010
3011         if (*enterops && enterops[1]) {
3012             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3013             if (enterops[i])
3014                 deprecate("\"goto\" to jump into a construct");
3015         }
3016
3017         /* pop unwanted frames */
3018
3019         if (ix < cxstack_ix) {
3020             if (ix < 0)
3021                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3022             dounwind(ix);
3023             cx = CX_CUR();
3024             cx_topblock(cx);
3025         }
3026
3027         /* push wanted frames */
3028
3029         if (*enterops && enterops[1]) {
3030             OP * const oldop = PL_op;
3031             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3032             for (; enterops[ix]; ix++) {
3033                 PL_op = enterops[ix];
3034                 /* Eventually we may want to stack the needed arguments
3035                  * for each op.  For now, we punt on the hard ones. */
3036                 if (PL_op->op_type == OP_ENTERITER)
3037                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3038                 PL_op->op_ppaddr(aTHX);
3039             }
3040             PL_op = oldop;
3041         }
3042     }
3043
3044     if (do_dump) {
3045 #ifdef VMS
3046         if (!retop) retop = PL_main_start;
3047 #endif
3048         PL_restartop = retop;
3049         PL_do_undump = TRUE;
3050
3051         my_unexec();
3052
3053         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3054         PL_do_undump = FALSE;
3055     }
3056
3057     putback_return:
3058     PL_stack_sp = sp;
3059     _return:
3060     PERL_ASYNC_CHECK();
3061     return retop;
3062 }
3063
3064 PP(pp_exit)
3065 {
3066     dSP;
3067     I32 anum;
3068
3069     if (MAXARG < 1)
3070         anum = 0;
3071     else if (!TOPs) {
3072         anum = 0; (void)POPs;
3073     }
3074     else {
3075         anum = SvIVx(POPs);
3076 #ifdef VMS
3077         if (anum == 1
3078          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3079             anum = 0;
3080         VMSISH_HUSHED  =
3081             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3082 #endif
3083     }
3084     PL_exit_flags |= PERL_EXIT_EXPECTED;
3085     my_exit(anum);
3086     PUSHs(&PL_sv_undef);
3087     RETURN;
3088 }
3089
3090 /* Eval. */
3091
3092 STATIC void
3093 S_save_lines(pTHX_ AV *array, SV *sv)
3094 {
3095     const char *s = SvPVX_const(sv);
3096     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3097     I32 line = 1;
3098
3099     PERL_ARGS_ASSERT_SAVE_LINES;
3100
3101     while (s && s < send) {
3102         const char *t;
3103         SV * const tmpstr = newSV_type(SVt_PVMG);
3104
3105         t = (const char *)memchr(s, '\n', send - s);
3106         if (t)
3107             t++;
3108         else
3109             t = send;
3110
3111         sv_setpvn(tmpstr, s, t - s);
3112         av_store(array, line++, tmpstr);
3113         s = t;
3114     }
3115 }
3116
3117 /*
3118 =for apidoc docatch
3119
3120 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3121
3122 0 is used as continue inside eval,
3123
3124 3 is used for a die caught by an inner eval - continue inner loop
3125
3126 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3127 establish a local jmpenv to handle exception traps.
3128
3129 =cut
3130 */
3131 STATIC OP *
3132 S_docatch(pTHX_ OP *o)
3133 {
3134     int ret;
3135     OP * const oldop = PL_op;
3136     dJMPENV;
3137
3138 #ifdef DEBUGGING
3139     assert(CATCH_GET == TRUE);
3140 #endif
3141     PL_op = o;
3142
3143     JMPENV_PUSH(ret);
3144     switch (ret) {
3145     case 0:
3146         assert(cxstack_ix >= 0);
3147         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3148         CX_CUR()->blk_eval.cur_top_env = PL_top_env;
3149  redo_body:
3150         CALLRUNOPS(aTHX);
3151         break;
3152     case 3:
3153         /* die caught by an inner eval - continue inner loop */
3154         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3155             PL_restartjmpenv = NULL;
3156             PL_op = PL_restartop;
3157             PL_restartop = 0;
3158             goto redo_body;
3159         }
3160         /* FALLTHROUGH */
3161     default:
3162         JMPENV_POP;
3163         PL_op = oldop;
3164         JMPENV_JUMP(ret);
3165         NOT_REACHED; /* NOTREACHED */
3166     }
3167     JMPENV_POP;
3168     PL_op = oldop;
3169     return NULL;
3170 }
3171
3172
3173 /*
3174 =for apidoc find_runcv
3175
3176 Locate the CV corresponding to the currently executing sub or eval.
3177 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3178 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3179 entered.  (This allows debuggers to eval in the scope of the breakpoint
3180 rather than in the scope of the debugger itself.)
3181
3182 =cut
3183 */
3184
3185 CV*
3186 Perl_find_runcv(pTHX_ U32 *db_seqp)
3187 {
3188     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3189 }
3190
3191 /* If this becomes part of the API, it might need a better name. */
3192 CV *
3193 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3194 {
3195     PERL_SI      *si;
3196     int          level = 0;
3197
3198     if (db_seqp)
3199         *db_seqp =
3200             PL_curcop == &PL_compiling
3201                 ? PL_cop_seqmax
3202                 : PL_curcop->cop_seq;
3203
3204     for (si = PL_curstackinfo; si; si = si->si_prev) {
3205         I32 ix;
3206         for (ix = si->si_cxix; ix >= 0; ix--) {
3207             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3208             CV *cv = NULL;
3209             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3210                 cv = cx->blk_sub.cv;
3211                 /* skip DB:: code */
3212                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3213                     *db_seqp = cx->blk_oldcop->cop_seq;
3214                     continue;
3215                 }
3216                 if (cx->cx_type & CXp_SUB_RE)
3217                     continue;
3218             }
3219             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3220                 cv = cx->blk_eval.cv;
3221             if (cv) {
3222                 switch (cond) {
3223                 case FIND_RUNCV_padid_eq:
3224                     if (!CvPADLIST(cv)
3225                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3226                         continue;
3227                     return cv;
3228                 case FIND_RUNCV_level_eq:
3229                     if (level++ != arg) continue;
3230                     /* GERONIMO! */
3231                 default:
3232                     return cv;
3233                 }
3234             }
3235         }
3236     }
3237     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3238 }
3239
3240
3241 /* Run yyparse() in a setjmp wrapper. Returns:
3242  *   0: yyparse() successful
3243  *   1: yyparse() failed
3244  *   3: yyparse() died
3245  */
3246 STATIC int
3247 S_try_yyparse(pTHX_ int gramtype)
3248 {
3249     int ret;
3250     dJMPENV;
3251
3252     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3253     JMPENV_PUSH(ret);
3254     switch (ret) {
3255     case 0:
3256         ret = yyparse(gramtype) ? 1 : 0;
3257         break;
3258     case 3:
3259         break;
3260     default:
3261         JMPENV_POP;
3262         JMPENV_JUMP(ret);
3263         NOT_REACHED; /* NOTREACHED */
3264     }
3265     JMPENV_POP;
3266     return ret;
3267 }
3268
3269
3270 /* Compile a require/do or an eval ''.
3271  *
3272  * outside is the lexically enclosing CV (if any) that invoked us.
3273  * seq     is the current COP scope value.
3274  * hh      is the saved hints hash, if any.
3275  *
3276  * Returns a bool indicating whether the compile was successful; if so,
3277  * PL_eval_start contains the first op of the compiled code; otherwise,
3278  * pushes undef.
3279  *
3280  * This function is called from two places: pp_require and pp_entereval.
3281  * These can be distinguished by whether PL_op is entereval.
3282  */
3283
3284 STATIC bool
3285 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3286 {
3287     dSP;
3288     OP * const saveop = PL_op;
3289     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3290     COP * const oldcurcop = PL_curcop;
3291     bool in_require = (saveop->op_type == OP_REQUIRE);
3292     int yystatus;
3293     CV *evalcv;
3294
3295     PL_in_eval = (in_require
3296                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3297                   : (EVAL_INEVAL |
3298                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3299                             ? EVAL_RE_REPARSING : 0)));
3300
3301     PUSHMARK(SP);
3302
3303     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3304     CvEVAL_on(evalcv);
3305     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3306     CX_CUR()->blk_eval.cv = evalcv;
3307     CX_CUR()->blk_gimme = gimme;
3308
3309     CvOUTSIDE_SEQ(evalcv) = seq;
3310     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3311
3312     /* set up a scratch pad */
3313
3314     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3315     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3316
3317
3318     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3319
3320     /* make sure we compile in the right package */
3321
3322     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3323         SAVEGENERICSV(PL_curstash);
3324         PL_curstash = (HV *)CopSTASH(PL_curcop);
3325         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3326         else SvREFCNT_inc_simple_void(PL_curstash);
3327     }
3328     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3329     SAVESPTR(PL_beginav);
3330     PL_beginav = newAV();
3331     SAVEFREESV(PL_beginav);
3332     SAVESPTR(PL_unitcheckav);
3333     PL_unitcheckav = newAV();
3334     SAVEFREESV(PL_unitcheckav);
3335
3336
3337     ENTER_with_name("evalcomp");
3338     SAVESPTR(PL_compcv);
3339     PL_compcv = evalcv;
3340
3341     /* try to compile it */
3342
3343     PL_eval_root = NULL;
3344     PL_curcop = &PL_compiling;
3345     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3346         PL_in_eval |= EVAL_KEEPERR;
3347     else
3348         CLEAR_ERRSV();
3349
3350     SAVEHINTS();
3351     if (clear_hints) {
3352         PL_hints = 0;
3353         hv_clear(GvHV(PL_hintgv));
3354     }
3355     else {
3356         PL_hints = saveop->op_private & OPpEVAL_COPHH
3357                      ? oldcurcop->cop_hints : saveop->op_targ;
3358
3359         /* making 'use re eval' not be in scope when compiling the
3360          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3361          * infinite recursion when S_has_runtime_code() gives a false
3362          * positive: the second time round, HINT_RE_EVAL isn't set so we
3363          * don't bother calling S_has_runtime_code() */
3364         if (PL_in_eval & EVAL_RE_REPARSING)
3365             PL_hints &= ~HINT_RE_EVAL;
3366
3367         if (hh) {
3368             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3369             SvREFCNT_dec(GvHV(PL_hintgv));
3370             GvHV(PL_hintgv) = hh;
3371         }
3372     }
3373     SAVECOMPILEWARNINGS();
3374     if (clear_hints) {
3375         if (PL_dowarn & G_WARN_ALL_ON)
3376             PL_compiling.cop_warnings = pWARN_ALL ;
3377         else if (PL_dowarn & G_WARN_ALL_OFF)
3378             PL_compiling.cop_warnings = pWARN_NONE ;
3379         else
3380             PL_compiling.cop_warnings = pWARN_STD ;
3381     }
3382     else {
3383         PL_compiling.cop_warnings =
3384             DUP_WARNINGS(oldcurcop->cop_warnings);
3385         cophh_free(CopHINTHASH_get(&PL_compiling));
3386         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3387             /* The label, if present, is the first entry on the chain. So rather
3388                than writing a blank label in front of it (which involves an
3389                allocation), just use the next entry in the chain.  */
3390             PL_compiling.cop_hints_hash
3391                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3392             /* Check the assumption that this removed the label.  */
3393             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3394         }
3395         else
3396             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3397     }
3398
3399     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3400
3401     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3402      * so honour CATCH_GET and trap it here if necessary */
3403
3404
3405     /* compile the code */
3406     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3407
3408     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3409         PERL_CONTEXT *cx;
3410         SV *errsv;
3411
3412         PL_op = saveop;
3413         /* note that if yystatus == 3, then the require/eval died during
3414          * compilation, so the EVAL CX block has already been popped, and
3415          * various vars restored */
3416         if (yystatus != 3) {
3417             if (PL_eval_root) {
3418                 op_free(PL_eval_root);
3419                 PL_eval_root = NULL;
3420             }
3421             SP = PL_stack_base + POPMARK;       /* pop original mark */
3422             cx = CX_CUR();
3423             assert(CxTYPE(cx) == CXt_EVAL);
3424             /* pop the CXt_EVAL, and if was a require, croak */
3425             S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3426         }
3427
3428         /* die_unwind() re-croaks when in require, having popped the
3429          * require EVAL context. So we should never catch a require
3430          * exception here */
3431         assert(!in_require);
3432
3433         errsv = ERRSV;
3434         if (!*(SvPV_nolen_const(errsv)))
3435             sv_setpvs(errsv, "Compilation error");
3436
3437         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3438         PUTBACK;
3439         return FALSE;
3440     }
3441
3442     /* Compilation successful. Now clean up */
3443
3444     LEAVE_with_name("evalcomp");
3445
3446     CopLINE_set(&PL_compiling, 0);
3447     SAVEFREEOP(PL_eval_root);
3448     cv_forget_slab(evalcv);
3449
3450     DEBUG_x(dump_eval());
3451
3452     /* Register with debugger: */
3453     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3454         CV * const cv = get_cvs("DB::postponed", 0);
3455         if (cv) {
3456             dSP;
3457             PUSHMARK(SP);
3458             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3459             PUTBACK;
3460             call_sv(MUTABLE_SV(cv), G_DISCARD);
3461         }
3462     }
3463
3464     if (PL_unitcheckav) {
3465         OP *es = PL_eval_start;
3466         call_list(PL_scopestack_ix, PL_unitcheckav);
3467         PL_eval_start = es;
3468     }
3469
3470     CvDEPTH(evalcv) = 1;
3471     SP = PL_stack_base + POPMARK;               /* pop original mark */
3472     PL_op = saveop;                     /* The caller may need it. */
3473     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3474
3475     PUTBACK;
3476     return TRUE;
3477 }
3478
3479
3480 STATIC PerlIO *
3481 S_check_type_and_open(pTHX_ SV *name)
3482 {
3483     Stat_t st;
3484     STRLEN len;
3485     PerlIO * retio;
3486     const char *p = SvPV_const(name, len);
3487     int st_rc;
3488
3489     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3490
3491     /* checking here captures a reasonable error message when
3492      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3493      * user gets a confusing message about looking for the .pmc file
3494      * rather than for the .pm file so do the check in S_doopen_pm when
3495      * PMC is on instead of here. S_doopen_pm calls this func.
3496      * This check prevents a \0 in @INC causing problems.
3497      */
3498 #ifdef PERL_DISABLE_PMC
3499     if (!IS_SAFE_PATHNAME(p, len, "require"))
3500         return NULL;
3501 #endif
3502
3503     /* on Win32 stat is expensive (it does an open() and close() twice and
3504        a couple other IO calls), the open will fail with a dir on its own with
3505        errno EACCES, so only do a stat to separate a dir from a real EACCES
3506        caused by user perms */
3507 #ifndef WIN32
3508     /* we use the value of errno later to see how stat() or open() failed.
3509      * We don't want it set if the stat succeeded but we still failed,
3510      * such as if the name exists, but is a directory */
3511     errno = 0;
3512
3513     st_rc = PerlLIO_stat(p, &st);
3514
3515     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3516         return NULL;
3517     }
3518 #endif
3519
3520     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3521 #ifdef WIN32
3522     /* EACCES stops the INC search early in pp_require to implement
3523        feature RT #113422 */
3524     if(!retio && errno == EACCES) { /* exists but probably a directory */
3525         int eno;
3526         st_rc = PerlLIO_stat(p, &st);
3527         if (st_rc >= 0) {
3528             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3529                 eno = 0;
3530             else
3531                 eno = EACCES;
3532             errno = eno;
3533         }
3534     }
3535 #endif
3536     return retio;
3537 }
3538
3539 #ifndef PERL_DISABLE_PMC
3540 STATIC PerlIO *
3541 S_doopen_pm(pTHX_ SV *name)
3542 {
3543     STRLEN namelen;
3544     const char *p = SvPV_const(name, namelen);
3545
3546     PERL_ARGS_ASSERT_DOOPEN_PM;
3547
3548     /* check the name before trying for the .pmc name to avoid the
3549      * warning referring to the .pmc which the user probably doesn't
3550      * know or care about
3551      */
3552     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3553         return NULL;
3554
3555     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3556         SV *const pmcsv = sv_newmortal();
3557         PerlIO * pmcio;
3558
3559         SvSetSV_nosteal(pmcsv,name);
3560         sv_catpvs(pmcsv, "c");
3561
3562         pmcio = check_type_and_open(pmcsv);
3563         if (pmcio)
3564             return pmcio;
3565     }
3566     return check_type_and_open(name);
3567 }
3568 #else
3569 #  define doopen_pm(name) check_type_and_open(name)
3570 #endif /* !PERL_DISABLE_PMC */
3571
3572 /* require doesn't search for absolute names, or when the name is
3573    explicitly relative the current directory */
3574 PERL_STATIC_INLINE bool
3575 S_path_is_searchable(const char *name)
3576 {
3577     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3578
3579     if (PERL_FILE_IS_ABSOLUTE(name)
3580 #ifdef WIN32
3581         || (*name == '.' && ((name[1] == '/' ||
3582                              (name[1] == '.' && name[2] == '/'))
3583                          || (name[1] == '\\' ||
3584                              ( name[1] == '.' && name[2] == '\\')))
3585             )
3586 #else
3587         || (*name == '.' && (name[1] == '/' ||
3588                              (name[1] == '.' && name[2] == '/')))
3589 #endif
3590          )
3591     {
3592         return FALSE;
3593     }
3594     else
3595         return TRUE;
3596 }
3597
3598
3599 /* implement 'require 5.010001' */
3600
3601 static OP *
3602 S_require_version(pTHX_ SV *sv)
3603 {
3604     dVAR; dSP;
3605
3606     sv = sv_2mortal(new_version(sv));
3607     if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3608         upg_version(PL_patchlevel, TRUE);
3609     if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3610         if ( vcmp(sv,PL_patchlevel) <= 0 )
3611             DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3612                 SVfARG(sv_2mortal(vnormal(sv))),
3613                 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3614             );
3615     }
3616     else {
3617         if ( vcmp(sv,PL_patchlevel) > 0 ) {
3618             I32 first = 0;
3619             AV *lav;
3620             SV * const req = SvRV(sv);
3621             SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3622
3623             /* get the left hand term */
3624             lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3625
3626             first  = SvIV(*av_fetch(lav,0,0));
3627             if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3628                 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3629                 || av_tindex(lav) > 1            /* FP with > 3 digits */
3630                 || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3631                ) {
3632                 DIE(aTHX_ "Perl %"SVf" required--this is only "
3633                     "%"SVf", stopped",
3634                     SVfARG(sv_2mortal(vnormal(req))),
3635                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3636                 );
3637             }
3638             else { /* probably 'use 5.10' or 'use 5.8' */
3639                 SV *hintsv;
3640                 I32 second = 0;
3641
3642                 if (av_tindex(lav)>=1)
3643                     second = SvIV(*av_fetch(lav,1,0));
3644
3645                 second /= second >= 600  ? 100 : 10;
3646                 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3647                                        (int)first, (int)second);
3648                 upg_version(hintsv, TRUE);
3649
3650                 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3651                     "--this is only %"SVf", stopped",
3652                     SVfARG(sv_2mortal(vnormal(req))),
3653                     SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3654                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3655                 );
3656             }
3657         }
3658     }
3659
3660     RETPUSHYES;
3661 }
3662
3663 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3664  * The first form will have already been converted at compile time to
3665  * the second form */
3666
3667 static OP *
3668 S_require_file(pTHX_ SV *const sv)
3669 {
3670     dVAR; dSP;
3671
3672     PERL_CONTEXT *cx;
3673     const char *name;
3674     STRLEN len;
3675     char * unixname;
3676     STRLEN unixlen;
3677 #ifdef VMS
3678     int vms_unixname = 0;
3679     char *unixdir;
3680 #endif
3681     const char *tryname = NULL;
3682     SV *namesv = NULL;
3683     const U8 gimme = GIMME_V;
3684     int filter_has_file = 0;
3685     PerlIO *tryrsfp = NULL;
3686     SV *filter_cache = NULL;
3687     SV *filter_state = NULL;
3688     SV *filter_sub = NULL;
3689     SV *hook_sv = NULL;
3690     OP *op;
3691     int saved_errno;
3692     bool path_searchable;
3693     I32 old_savestack_ix;
3694
3695     if (!SvOK(sv))
3696         DIE(aTHX_ "Missing or undefined argument to require");
3697     name = SvPV_nomg_const(sv, len);
3698     if (!(name && len > 0 && *name))
3699         DIE(aTHX_ "Missing or undefined argument to require");
3700
3701     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3702         DIE(aTHX_ "Can't locate %s:   %s",
3703             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3704                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3705             Strerror(ENOENT));
3706     }
3707     TAINT_PROPER("require");
3708
3709     path_searchable = path_is_searchable(name);
3710
3711 #ifdef VMS
3712     /* The key in the %ENV hash is in the syntax of file passed as the argument
3713      * usually this is in UNIX format, but sometimes in VMS format, which
3714      * can result in a module being pulled in more than once.
3715      * To prevent this, the key must be stored in UNIX format if the VMS
3716      * name can be translated to UNIX.
3717      */
3718
3719     if ((unixname =
3720           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3721          != NULL) {
3722         unixlen = strlen(unixname);
3723         vms_unixname = 1;
3724     }
3725     else
3726 #endif
3727     {
3728         /* if not VMS or VMS name can not be translated to UNIX, pass it
3729          * through.
3730          */
3731         unixname = (char *) name;
3732         unixlen = len;
3733     }
3734     if (PL_op->op_type == OP_REQUIRE) {
3735         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3736                                           unixname, unixlen, 0);
3737         if ( svp ) {
3738             if (*svp != &PL_sv_undef)
3739                 RETPUSHYES;
3740             else
3741                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3742                             "Compilation failed in require", unixname);
3743         }
3744
3745         if (PL_op->op_flags & OPf_KIDS) {
3746             SVOP * const kid = (SVOP*)cUNOP->op_first;
3747
3748             if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3749                 /* require foo (or use foo) with a bareword.
3750                    Perl_load_module fakes up the identical optree, but its
3751                    arguments aren't restricted by the parser to real barewords.
3752                 */
3753                 const STRLEN package_len = len - 3;
3754                 const char slashdot[2] = {'/', '.'};
3755 #ifdef DOSISH
3756                 const char backslashdot[2] = {'\\', '.'};
3757 #endif
3758
3759                 /* Disallow *purported* barewords that map to absolute
3760                    filenames, filenames relative to the current or parent
3761                    directory, or (*nix) hidden filenames.  Also sanity check
3762                    that the generated filename ends .pm  */
3763                 if (!path_searchable || len < 3 || name[0] == '.'
3764                     || !memEQ(name + package_len, ".pm", 3))
3765                     DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
3766                 if (memchr(name, 0, package_len)) {
3767                     /* diag_listed_as: Bareword in require contains "%s" */
3768                     DIE(aTHX_ "Bareword in require contains \"\\0\"");
3769                 }
3770                 if (ninstr(name, name + package_len, slashdot,
3771                            slashdot + sizeof(slashdot))) {
3772                     /* diag_listed_as: Bareword in require contains "%s" */
3773                     DIE(aTHX_ "Bareword in require contains \"/.\"");
3774                 }
3775 #ifdef DOSISH
3776                 if (ninstr(name, name + package_len, backslashdot,
3777                            backslashdot + sizeof(backslashdot))) {
3778                     /* diag_listed_as: Bareword in require contains "%s" */
3779                     DIE(aTHX_ "Bareword in require contains \"\\.\"");
3780                 }
3781 #endif
3782             }
3783         }
3784     }
3785
3786     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3787
3788     /* prepare to compile file */
3789
3790     if (!path_searchable) {
3791         /* At this point, name is SvPVX(sv)  */
3792         tryname = name;
3793         tryrsfp = doopen_pm(sv);
3794     }
3795     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3796         AV * const ar = GvAVn(PL_incgv);
3797         SSize_t i;
3798 #ifdef VMS
3799         if (vms_unixname)
3800 #endif
3801         {
3802             SV *nsv = sv;
3803             namesv = newSV_type(SVt_PV);
3804             for (i = 0; i <= AvFILL(ar); i++) {
3805                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3806
3807                 SvGETMAGIC(dirsv);
3808                 if (SvROK(dirsv)) {
3809                     int count;
3810                     SV **svp;
3811                     SV *loader = dirsv;
3812
3813                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3814                         && !SvOBJECT(SvRV(loader)))
3815                     {
3816                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3817                         SvGETMAGIC(loader);
3818                     }
3819
3820                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3821                                    PTR2UV(SvRV(dirsv)), name);
3822                     tryname = SvPVX_const(namesv);
3823                     tryrsfp = NULL;
3824
3825                     if (SvPADTMP(nsv)) {
3826                         nsv = sv_newmortal();
3827                         SvSetSV_nosteal(nsv,sv);
3828                     }
3829
3830                     ENTER_with_name("call_INC");
3831                     SAVETMPS;
3832                     EXTEND(SP, 2);
3833
3834                     PUSHMARK(SP);
3835                     PUSHs(dirsv);
3836                     PUSHs(nsv);
3837                     PUTBACK;
3838                     if (SvGMAGICAL(loader)) {
3839                         SV *l = sv_newmortal();
3840                         sv_setsv_nomg(l, loader);
3841                         loader = l;
3842                     }
3843                     if (sv_isobject(loader))
3844                         count = call_method("INC", G_ARRAY);
3845                     else
3846                         count = call_sv(loader, G_ARRAY);
3847                     SPAGAIN;
3848
3849                     if (count > 0) {
3850                         int i = 0;
3851                         SV *arg;
3852
3853                         SP -= count - 1;
3854                         arg = SP[i++];
3855
3856                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3857                             && !isGV_with_GP(SvRV(arg))) {
3858                             filter_cache = SvRV(arg);
3859
3860                             if (i < count) {
3861                                 arg = SP[i++];
3862                             }
3863                         }
3864
3865                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3866                             arg = SvRV(arg);
3867                         }
3868
3869                         if (isGV_with_GP(arg)) {
3870                             IO * const io = GvIO((const GV *)arg);
3871
3872                             ++filter_has_file;
3873
3874                             if (io) {
3875                                 tryrsfp = IoIFP(io);
3876                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3877                                     PerlIO_close(IoOFP(io));
3878                                 }
3879                                 IoIFP(io) = NULL;
3880                                 IoOFP(io) = NULL;
3881                             }
3882
3883                             if (i < count) {
3884                                 arg = SP[i++];
3885                             }
3886                         }
3887
3888                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3889                             filter_sub = arg;
3890                             SvREFCNT_inc_simple_void_NN(filter_sub);
3891
3892                             if (i < count) {
3893                                 filter_state = SP[i];
3894                                 SvREFCNT_inc_simple_void(filter_state);
3895                             }
3896                         }
3897
3898                         if (!tryrsfp && (filter_cache || filter_sub)) {
3899                             tryrsfp = PerlIO_open(BIT_BUCKET,
3900                                                   PERL_SCRIPT_MODE);
3901                         }
3902                         SP--;
3903                     }
3904
3905                     /* FREETMPS may free our filter_cache */
3906                     SvREFCNT_inc_simple_void(filter_cache);
3907
3908                     PUTBACK;
3909                     FREETMPS;
3910                     LEAVE_with_name("call_INC");
3911
3912                     /* Now re-mortalize it. */
3913                     sv_2mortal(filter_cache);
3914
3915                     /* Adjust file name if the hook has set an %INC entry.
3916                        This needs to happen after the FREETMPS above.  */
3917                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3918                     if (svp)
3919                         tryname = SvPV_nolen_const(*svp);
3920
3921                     if (tryrsfp) {
3922                         hook_sv = dirsv;
3923                         break;
3924                     }
3925
3926                     filter_has_file = 0;
3927                     filter_cache = NULL;
3928                     if (filter_state) {
3929                         SvREFCNT_dec_NN(filter_state);
3930                         filter_state = NULL;
3931                     }
3932                     if (filter_sub) {
3933                         SvREFCNT_dec_NN(filter_sub);
3934                         filter_sub = NULL;
3935                     }
3936                 }
3937                 else {
3938                   if (path_searchable) {
3939                     const char *dir;
3940                     STRLEN dirlen;
3941
3942                     if (SvOK(dirsv)) {
3943                         dir = SvPV_nomg_const(dirsv, dirlen);
3944                     } else {
3945                         dir = "";
3946                         dirlen = 0;
3947                     }
3948
3949                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3950                         continue;
3951 #ifdef VMS
3952                     if ((unixdir =
3953                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3954                          == NULL)
3955                         continue;
3956                     sv_setpv(namesv, unixdir);
3957                     sv_catpv(namesv, unixname);
3958 #else
3959 #  ifdef __SYMBIAN32__
3960                     if (PL_origfilename[0] &&
3961                         PL_origfilename[1] == ':' &&
3962                         !(dir[0] && dir[1] == ':'))
3963                         Perl_sv_setpvf(aTHX_ namesv,
3964                                        "%c:%s\\%s",
3965                                        PL_origfilename[0],
3966                                        dir, name);
3967                     else
3968                         Perl_sv_setpvf(aTHX_ namesv,
3969                                        "%s\\%s",
3970                                        dir, name);
3971 #  else
3972                     /* The equivalent of
3973                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3974                        but without the need to parse the format string, or
3975                        call strlen on either pointer, and with the correct
3976                        allocation up front.  */
3977                     {
3978                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3979
3980                         memcpy(tmp, dir, dirlen);
3981                         tmp +=dirlen;
3982
3983                         /* Avoid '<dir>//<file>' */
3984                         if (!dirlen || *(tmp-1) != '/') {
3985                             *tmp++ = '/';
3986                         } else {
3987                             /* So SvCUR_set reports the correct length below */
3988                             dirlen--;
3989                         }
3990
3991                         /* name came from an SV, so it will have a '\0' at the
3992                            end that we can copy as part of this memcpy().  */
3993                         memcpy(tmp, name, len + 1);
3994
3995                         SvCUR_set(namesv, dirlen + len + 1);
3996                         SvPOK_on(namesv);
3997                     }
3998 #  endif
3999 #endif
4000                     TAINT_PROPER("require");
4001                     tryname = SvPVX_const(namesv);
4002                     tryrsfp = doopen_pm(namesv);
4003                     if (tryrsfp) {
4004                         if (tryname[0] == '.' && tryname[1] == '/') {
4005                             ++tryname;
4006                             while (*++tryname == '/') {}
4007                         }
4008                         break;
4009                     }
4010                     else if (errno == EMFILE || errno == EACCES) {
4011                         /* no point in trying other paths if out of handles;
4012                          * on the other hand, if we couldn't open one of the
4013                          * files, then going on with the search could lead to
4014                          * unexpected results; see perl #113422
4015                          */
4016                         break;
4017                     }
4018                   }
4019                 }
4020             }
4021         }
4022     }
4023     saved_errno = errno; /* sv_2mortal can realloc things */
4024     sv_2mortal(namesv);
4025     if (!tryrsfp) {
4026         if (PL_op->op_type == OP_REQUIRE) {
4027             if(saved_errno == EMFILE || saved_errno == EACCES) {
4028                 /* diag_listed_as: Can't locate %s */
4029                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4030                     name, tryname, Strerror(saved_errno));
4031             } else {
4032                 if (namesv) {                   /* did we lookup @INC? */
4033                     AV * const ar = GvAVn(PL_incgv);
4034                     SSize_t i;
4035                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4036                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4037                     for (i = 0; i <= AvFILL(ar); i++) {
4038                         sv_catpvs(inc, " ");
4039                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4040                     }
4041                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4042                         const char *c, *e = name + len - 3;
4043                         sv_catpv(msg, " (you may need to install the ");
4044                         for (c = name; c < e; c++) {
4045                             if (*c == '/') {
4046                                 sv_catpvs(msg, "::");
4047                             }
4048                             else {
4049                                 sv_catpvn(msg, c, 1);
4050                             }
4051                         }
4052                         sv_catpv(msg, " module)");
4053                     }
4054                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4055                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4056                     }
4057                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4058                         sv_catpv(msg, " (did you run h2ph?)");
4059                     }
4060
4061                     /* diag_listed_as: Can't locate %s */
4062                     DIE(aTHX_
4063                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4064                         name, msg, inc);
4065                 }
4066             }
4067             DIE(aTHX_ "Can't locate %s", name);
4068         }
4069
4070         CLEAR_ERRSV();
4071         RETPUSHUNDEF;
4072     }
4073     else
4074         SETERRNO(0, SS_NORMAL);
4075
4076     /* Assume success here to prevent recursive requirement. */
4077     /* name is never assigned to again, so len is still strlen(name)  */
4078     /* Check whether a hook in @INC has already filled %INC */
4079     if (!hook_sv) {
4080         (void)hv_store(GvHVn(PL_incgv),
4081                        unixname, unixlen, newSVpv(tryname,0),0);
4082     } else {
4083         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4084         if (!svp)
4085             (void)hv_store(GvHVn(PL_incgv),
4086                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4087     }
4088
4089     old_savestack_ix = PL_savestack_ix;
4090     SAVECOPFILE_FREE(&PL_compiling);
4091     CopFILE_set(&PL_compiling, tryname);
4092     lex_start(NULL, tryrsfp, 0);
4093
4094     if (filter_sub || filter_cache) {
4095         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4096            than hanging another SV from it. In turn, filter_add() optionally
4097            takes the SV to use as the filter (or creates a new SV if passed
4098            NULL), so simply pass in whatever value filter_cache has.  */
4099         SV * const fc = filter_cache ? newSV(0) : NULL;
4100         SV *datasv;
4101         if (fc) sv_copypv(fc, filter_cache);
4102         datasv = filter_add(S_run_user_filter, fc);
4103         IoLINES(datasv) = filter_has_file;
4104         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4105         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4106     }
4107
4108     /* switch to eval mode */
4109     cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4110     cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4111
4112     SAVECOPLINE(&PL_compiling);
4113     CopLINE_set(&PL_compiling, 0);
4114
4115     PUTBACK;
4116
4117     if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4118         op = DOCATCH(PL_eval_start);
4119     else
4120         op = PL_op->op_next;
4121
4122     PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4123
4124     return op;
4125 }
4126
4127
4128 /* also used for: pp_dofile() */
4129
4130 PP(pp_require)
4131 {
4132     dSP;
4133     SV *sv = POPs;
4134     SvGETMAGIC(sv);
4135     PUTBACK;
4136     return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4137         ? S_require_version(aTHX_ sv)
4138         : S_require_file(aTHX_ sv);
4139 }
4140
4141
4142 /* This is a op added to hold the hints hash for
4143    pp_entereval. The hash can be modified by the code
4144    being eval'ed, so we return a copy instead. */
4145
4146 PP(pp_hintseval)
4147 {
4148     dSP;
4149     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4150     RETURN;
4151 }
4152
4153
4154 PP(pp_entereval)
4155 {
4156     dSP;
4157     PERL_CONTEXT *cx;
4158     SV *sv;
4159     const U8 gimme = GIMME_V;
4160     const U32 was = PL_breakable_sub_gen;
4161     char tbuf[TYPE_DIGITS(long) + 12];
4162     bool saved_delete = FALSE;
4163     char *tmpbuf = tbuf;
4164     STRLEN len;
4165     CV* runcv;
4166     U32 seq, lex_flags = 0;
4167     HV *saved_hh = NULL;
4168     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4169     I32 old_savestack_ix;
4170
4171     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4172         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4173     }
4174     else if (PL_hints & HINT_LOCALIZE_HH || (
4175                 PL_op->op_private & OPpEVAL_COPHH
4176              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4177             )) {
4178         saved_hh = cop_hints_2hv(PL_curcop, 0);
4179         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4180     }
4181     sv = POPs;
4182     if (!SvPOK(sv)) {
4183         /* make sure we've got a plain PV (no overload etc) before testing
4184          * for taint. Making a copy here is probably overkill, but better
4185          * safe than sorry */
4186         STRLEN len;
4187         const char * const p = SvPV_const(sv, len);
4188
4189         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4190         lex_flags |= LEX_START_COPIED;
4191
4192         if (bytes && SvUTF8(sv))
4193             SvPVbyte_force(sv, len);
4194     }
4195     else if (bytes && SvUTF8(sv)) {
4196         /* Don't modify someone else's scalar */
4197         STRLEN len;
4198         sv = newSVsv(sv);
4199         (void)sv_2mortal(sv);
4200         SvPVbyte_force(sv,len);
4201         lex_flags |= LEX_START_COPIED;
4202     }
4203
4204     TAINT_IF(SvTAINTED(sv));
4205     TAINT_PROPER("eval");
4206
4207     old_savestack_ix = PL_savestack_ix;
4208
4209     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4210                            ? LEX_IGNORE_UTF8_HINTS
4211                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4212                         )
4213              );
4214
4215     /* switch to eval mode */
4216
4217     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4218         SV * const temp_sv = sv_newmortal();
4219         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4220                        (unsigned long)++PL_evalseq,
4221                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4222         tmpbuf = SvPVX(temp_sv);
4223         len = SvCUR(temp_sv);
4224     }
4225     else
4226         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4227     SAVECOPFILE_FREE(&PL_compiling);
4228     CopFILE_set(&PL_compiling, tmpbuf+2);
4229     SAVECOPLINE(&PL_compiling);
4230     CopLINE_set(&PL_compiling, 1);
4231     /* special case: an eval '' executed within the DB package gets lexically
4232      * placed in the first non-DB CV rather than the current CV - this
4233      * allows the debugger to execute code, find lexicals etc, in the
4234      * scope of the code being debugged. Passing &seq gets find_runcv
4235      * to do the dirty work for us */
4236     runcv = find_runcv(&seq);
4237
4238     cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4239     cx_pusheval(cx, PL_op->op_next, NULL);
4240
4241     /* prepare to compile string */
4242
4243     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4244         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4245     else {
4246         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4247            deleting the eval's FILEGV from the stash before gv_check() runs
4248            (i.e. before run-time proper). To work around the coredump that
4249            ensues, we always turn GvMULTI_on for any globals that were
4250            introduced within evals. See force_ident(). GSAR 96-10-12 */
4251         char *const safestr = savepvn(tmpbuf, len);
4252         SAVEDELETE(PL_defstash, safestr, len);
4253         saved_delete = TRUE;
4254     }
4255
4256     PUTBACK;
4257
4258     if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4259         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4260             ?  PERLDB_LINE_OR_SAVESRC
4261             :  PERLDB_SAVESRC_NOSUBS) {
4262             /* Retain the filegv we created.  */
4263         } else if (!saved_delete) {
4264             char *const safestr = savepvn(tmpbuf, len);
4265             SAVEDELETE(PL_defstash, safestr, len);
4266         }
4267         return DOCATCH(PL_eval_start);
4268     } else {
4269         /* We have already left the scope set up earlier thanks to the LEAVE
4270            in doeval_compile().  */
4271         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4272             ?  PERLDB_LINE_OR_SAVESRC
4273             :  PERLDB_SAVESRC_INVALID) {
4274             /* Retain the filegv we created.  */
4275         } else if (!saved_delete) {
4276             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4277         }
4278         return PL_op->op_next;
4279     }
4280 }
4281
4282
4283 /* also tail-called by pp_return */
4284
4285 PP(pp_leaveeval)
4286 {
4287     SV **oldsp;
4288     U8 gimme;
4289     PERL_CONTEXT *cx;
4290     OP *retop;
4291     int failed;
4292     CV *evalcv;
4293     bool keep;
4294
4295     PERL_ASYNC_CHECK();
4296
4297     cx = CX_CUR();
4298     assert(CxTYPE(cx) == CXt_EVAL);
4299
4300     oldsp = PL_stack_base + cx->blk_oldsp;
4301     gimme = cx->blk_gimme;
4302
4303     /* did require return a false value? */
4304     failed =    CxOLD_OP_TYPE(cx) == OP_REQUIRE
4305              && !(gimme == G_SCALAR
4306                     ? SvTRUE(*PL_stack_sp)
4307                     : PL_stack_sp > oldsp);
4308
4309     if (gimme == G_VOID)
4310         PL_stack_sp = oldsp;
4311     else
4312         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4313
4314     /* the cx_popeval does a leavescope, which frees the optree associated
4315      * with eval, which if it frees the nextstate associated with
4316      * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4317      * regex when running under 'use re Debug' because it needs PL_curcop
4318      * to get the current hints. So restore it early.
4319      */
4320     PL_curcop = cx->blk_oldcop;
4321
4322     /* grab this value before cx_popeval restores the old PL_in_eval */
4323     keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4324     retop = cx->blk_eval.retop;
4325     evalcv = cx->blk_eval.cv;
4326 #ifdef DEBUGGING
4327     assert(CvDEPTH(evalcv) == 1);
4328 #endif
4329     CvDEPTH(evalcv) = 0;
4330
4331     /* pop the CXt_EVAL, and if a require failed, croak */
4332     S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4333
4334     if (!keep)
4335         CLEAR_ERRSV();
4336
4337     return retop;
4338 }
4339
4340 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4341    close to the related Perl_create_eval_scope.  */
4342 void
4343 Perl_delete_eval_scope(pTHX)
4344 {
4345     PERL_CONTEXT *cx;
4346
4347     cx = CX_CUR();
4348     CX_LEAVE_SCOPE(cx);
4349     cx_popeval(cx);
4350     cx_popblock(cx);
4351     CX_POP(cx);
4352 }
4353
4354 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4355    also needed by Perl_fold_constants.  */
4356 void
4357 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4358 {
4359     PERL_CONTEXT *cx;
4360     const U8 gimme = GIMME_V;
4361
4362     cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4363                     PL_stack_sp, PL_savestack_ix);
4364     cx_pusheval(cx, retop, NULL);
4365
4366     PL_in_eval = EVAL_INEVAL;
4367     if (flags & G_KEEPERR)
4368         PL_in_eval |= EVAL_KEEPERR;
4369     else
4370         CLEAR_ERRSV();
4371     if (flags & G_FAKINGEVAL) {
4372         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4373     }
4374 }
4375
4376 PP(pp_entertry)
4377 {
4378     create_eval_scope(cLOGOP->op_other->op_next, 0);
4379     return DOCATCH(PL_op->op_next);
4380 }
4381
4382
4383 /* also tail-called by pp_return */
4384
4385 PP(pp_leavetry)
4386 {
4387     SV **oldsp;
4388     U8 gimme;
4389     PERL_CONTEXT *cx;
4390     OP *retop;
4391
4392     PERL_ASYNC_CHECK();
4393
4394     cx = CX_CUR();
4395     assert(CxTYPE(cx) == CXt_EVAL);
4396     oldsp = PL_stack_base + cx->blk_oldsp;
4397     gimme = cx->blk_gimme;
4398
4399     if (gimme == G_VOID)
4400         PL_stack_sp = oldsp;
4401     else
4402         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4403     CX_LEAVE_SCOPE(cx);
4404     cx_popeval(cx);
4405     cx_popblock(cx);
4406     retop = cx->blk_eval.retop;
4407     CX_POP(cx);
4408
4409     CLEAR_ERRSV();
4410     return retop;
4411 }
4412
4413 PP(pp_entergiven)
4414 {
4415     dSP;
4416     PERL_CONTEXT *cx;
4417     const U8 gimme = GIMME_V;
4418     SV *origsv = DEFSV;
4419     SV *newsv = POPs;
4420
4421     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4422     GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4423
4424     cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4425     cx_pushgiven(cx, origsv);
4426
4427     RETURN;
4428 }
4429
4430 PP(pp_leavegiven)
4431 {
4432     PERL_CONTEXT *cx;
4433     U8 gimme;
4434     SV **oldsp;
4435     PERL_UNUSED_CONTEXT;
4436
4437     cx = CX_CUR();
4438     assert(CxTYPE(cx) == CXt_GIVEN);
4439     oldsp = PL_stack_base + cx->blk_oldsp;
4440     gimme = cx->blk_gimme;
4441
4442     if (gimme == G_VOID)
4443         PL_stack_sp = oldsp;
4444     else
4445         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4446
4447     CX_LEAVE_SCOPE(cx);
4448     cx_popgiven(cx);
4449     cx_popblock(cx);
4450     CX_POP(cx);
4451
4452     return NORMAL;
4453 }
4454
4455 /* Helper routines used by pp_smartmatch */
4456 STATIC PMOP *
4457 S_make_matcher(pTHX_ REGEXP *re)
4458 {
4459     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4460
4461     PERL_ARGS_ASSERT_MAKE_MATCHER;
4462
4463     PM_SETRE(matcher, ReREFCNT_inc(re));
4464
4465     SAVEFREEOP((OP *) matcher);
4466     ENTER_with_name("matcher"); SAVETMPS;
4467     SAVEOP();
4468     return matcher;
4469 }
4470
4471 STATIC bool
4472 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4473 {
4474     dSP;
4475     bool result;
4476
4477     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4478
4479     PL_op = (OP *) matcher;
4480     XPUSHs(sv);
4481     PUTBACK;
4482     (void) Perl_pp_match(aTHX);
4483     SPAGAIN;
4484     result = SvTRUEx(POPs);
4485     PUTBACK;
4486
4487     return result;
4488 }
4489
4490 STATIC void
4491 S_destroy_matcher(pTHX_ PMOP *matcher)
4492 {
4493     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4494     PERL_UNUSED_ARG(matcher);
4495
4496     FREETMPS;
4497     LEAVE_with_name("matcher");
4498 }
4499
4500 /* Do a smart match */
4501 PP(pp_smartmatch)
4502 {
4503     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4504     return do_smartmatch(NULL, NULL, 0);
4505 }
4506
4507 /* This version of do_smartmatch() implements the
4508  * table of smart matches that is found in perlsyn.
4509  */
4510 STATIC OP *
4511 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4512 {
4513     dSP;
4514
4515     bool object_on_left = FALSE;
4516     SV *e = TOPs;       /* e is for 'expression' */
4517     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4518
4519     /* Take care only to invoke mg_get() once for each argument.
4520      * Currently we do this by copying the SV if it's magical. */
4521     if (d) {
4522         if (!copied && SvGMAGICAL(d))
4523             d = sv_mortalcopy(d);
4524     }
4525     else
4526         d = &PL_sv_undef;
4527
4528     assert(e);
4529     if (SvGMAGICAL(e))
4530         e = sv_mortalcopy(e);
4531
4532     /* First of all, handle overload magic of the rightmost argument */
4533     if (SvAMAGIC(e)) {
4534         SV * tmpsv;
4535         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4536         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4537
4538         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4539         if (tmpsv) {
4540             SPAGAIN;
4541             (void)POPs;
4542             SETs(tmpsv);
4543             RETURN;
4544         }
4545         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4546     }
4547
4548     SP -= 2;    /* Pop the values */
4549     PUTBACK;
4550
4551     /* ~~ undef */
4552     if (!SvOK(e)) {
4553         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4554         if (SvOK(d))
4555             RETPUSHNO;
4556         else
4557             RETPUSHYES;
4558     }
4559
4560     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4561         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4562         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4563     }
4564     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4565         object_on_left = TRUE;
4566
4567     /* ~~ sub */
4568     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4569         I32 c;
4570         if (object_on_left) {
4571             goto sm_any_sub; /* Treat objects like scalars */
4572         }
4573         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4574             /* Test sub truth for each key */
4575             HE *he;
4576             bool andedresults = TRUE;
4577             HV *hv = (HV*) SvRV(d);
4578             I32 numkeys = hv_iterinit(hv);
4579             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4580             if (numkeys == 0)
4581                 RETPUSHYES;
4582             while ( (he = hv_iternext(hv)) ) {
4583                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4584                 ENTER_with_name("smartmatch_hash_key_test");
4585                 SAVETMPS;
4586                 PUSHMARK(SP);
4587                 PUSHs(hv_iterkeysv(he));
4588                 PUTBACK;
4589                 c = call_sv(e, G_SCALAR);
4590                 SPAGAIN;
4591                 if (c == 0)
4592                     andedresults = FALSE;
4593                 else
4594                     andedresults = SvTRUEx(POPs) && andedresults;
4595                 FREETMPS;
4596                 LEAVE_with_name("smartmatch_hash_key_test");
4597             }
4598             if (andedresults)
4599                 RETPUSHYES;
4600             else
4601                 RETPUSHNO;
4602         }
4603         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4604             /* Test sub truth for each element */
4605             SSize_t i;
4606             bool andedresults = TRUE;
4607             AV *av = (AV*) SvRV(d);
4608             const I32 len = av_tindex(av);
4609             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4610             if (len == -1)
4611                 RETPUSHYES;
4612             for (i = 0; i <= len; ++i) {
4613                 SV * const * const svp = av_fetch(av, i, FALSE);
4614                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4615                 ENTER_with_name("smartmatch_array_elem_test");
4616                 SAVETMPS;
4617                 PUSHMARK(SP);
4618                 if (svp)
4619                     PUSHs(*svp);
4620                 PUTBACK;
4621                 c = call_sv(e, G_SCALAR);
4622                 SPAGAIN;
4623                 if (c == 0)
4624                     andedresults = FALSE;
4625                 else
4626                     andedresults = SvTRUEx(POPs) && andedresults;
4627                 FREETMPS;
4628                 LEAVE_with_name("smartmatch_array_elem_test");
4629             }
4630             if (andedresults)
4631                 RETPUSHYES;
4632             else
4633                 RETPUSHNO;
4634         }
4635         else {
4636           sm_any_sub:
4637             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4638             ENTER_with_name("smartmatch_coderef");
4639             SAVETMPS;
4640             PUSHMARK(SP);
4641             PUSHs(d);
4642             PUTBACK;
4643             c = call_sv(e, G_SCALAR);
4644             SPAGAIN;
4645             if (c == 0)
4646                 PUSHs(&PL_sv_no);
4647             else if (SvTEMP(TOPs))
4648                 SvREFCNT_inc_void(TOPs);
4649             FREETMPS;
4650             LEAVE_with_name("smartmatch_coderef");
4651             RETURN;
4652         }
4653     }
4654     /* ~~ %hash */
4655     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4656         if (object_on_left) {
4657             goto sm_any_hash; /* Treat objects like scalars */
4658         }
4659         else if (!SvOK(d)) {
4660             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4661             RETPUSHNO;
4662         }
4663         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4664             /* Check that the key-sets are identical */
4665             HE *he;
4666             HV *other_hv = MUTABLE_HV(SvRV(d));
4667             bool tied;
4668             bool other_tied;
4669             U32 this_key_count  = 0,
4670                 other_key_count = 0;
4671             HV *hv = MUTABLE_HV(SvRV(e));
4672
4673             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4674             /* Tied hashes don't know how many keys they have. */
4675             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4676             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4677             if (!tied ) {
4678                 if(other_tied) {
4679                     /* swap HV sides */
4680                     HV * const temp = other_hv;
4681                     other_hv = hv;
4682                     hv = temp;
4683                     tied = TRUE;
4684                     other_tied = FALSE;
4685                 }
4686                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4687                     RETPUSHNO;
4688             }
4689
4690             /* The hashes have the same number of keys, so it suffices
4691                to check that one is a subset of the other. */
4692             (void) hv_iterinit(hv);
4693             while ( (he = hv_iternext(hv)) ) {
4694                 SV *key = hv_iterkeysv(he);
4695
4696                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4697                 ++ this_key_count;
4698
4699                 if(!hv_exists_ent(other_hv, key, 0)) {
4700                     (void) hv_iterinit(hv);     /* reset iterator */
4701                     RETPUSHNO;
4702                 }
4703             }
4704
4705             if (other_tied) {
4706                 (void) hv_iterinit(other_hv);
4707                 while ( hv_iternext(other_hv) )
4708                     ++other_key_count;
4709             }
4710             else
4711                 other_key_count = HvUSEDKEYS(other_hv);
4712
4713             if (this_key_count != other_key_count)
4714                 RETPUSHNO;
4715             else
4716                 RETPUSHYES;
4717         }
4718         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4719             AV * const other_av = MUTABLE_AV(SvRV(d));
4720             const SSize_t other_len = av_tindex(other_av) + 1;
4721             SSize_t i;
4722             HV *hv = MUTABLE_HV(SvRV(e));
4723
4724             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4725             for (i = 0; i < other_len; ++i) {
4726                 SV ** const svp = av_fetch(other_av, i, FALSE);
4727                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4728                 if (svp) {      /* ??? When can this not happen? */
4729                     if (hv_exists_ent(hv, *svp, 0))
4730                         RETPUSHYES;
4731                 }
4732             }
4733             RETPUSHNO;
4734         }
4735         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4736             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4737           sm_regex_hash:
4738             {
4739                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4740                 HE *he;
4741                 HV *hv = MUTABLE_HV(SvRV(e));
4742
4743                 (void) hv_iterinit(hv);
4744                 while ( (he = hv_iternext(hv)) ) {
4745                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4746                     PUTBACK;
4747                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4748                         SPAGAIN;
4749                         (void) hv_iterinit(hv);
4750                         destroy_matcher(matcher);
4751                         RETPUSHYES;
4752                     }
4753                     SPAGAIN;
4754                 }
4755                 destroy_matcher(matcher);
4756                 RETPUSHNO;
4757             }
4758         }
4759         else {
4760           sm_any_hash:
4761             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4762             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4763                 RETPUSHYES;
4764             else
4765                 RETPUSHNO;
4766         }
4767     }
4768     /* ~~ @array */
4769     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4770         if (object_on_left) {
4771             goto sm_any_array; /* Treat objects like scalars */
4772         }
4773         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4774             AV * const other_av = MUTABLE_AV(SvRV(e));
4775             const SSize_t other_len = av_tindex(other_av) + 1;
4776             SSize_t i;
4777
4778             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4779             for (i = 0; i < other_len; ++i) {
4780                 SV ** const svp = av_fetch(other_av, i, FALSE);
4781
4782                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4783                 if (svp) {      /* ??? When can this not happen? */
4784                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4785                         RETPUSHYES;
4786                 }
4787             }
4788             RETPUSHNO;
4789         }
4790         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4791             AV *other_av = MUTABLE_AV(SvRV(d));
4792             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4793             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4794                 RETPUSHNO;
4795             else {
4796                 SSize_t i;
4797                 const SSize_t other_len = av_tindex(other_av);
4798
4799                 if (NULL == seen_this) {
4800                     seen_this = newHV();
4801                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4802                 }
4803                 if (NULL == seen_other) {
4804                     seen_other = newHV();
4805                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4806                 }
4807                 for(i = 0; i <= other_len; ++i) {
4808                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4809                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4810
4811                     if (!this_elem || !other_elem) {
4812                         if ((this_elem && SvOK(*this_elem))
4813                                 || (other_elem && SvOK(*other_elem)))
4814                             RETPUSHNO;
4815                     }
4816                     else if (hv_exists_ent(seen_this,
4817                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4818                             hv_exists_ent(seen_other,
4819                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4820                     {
4821                         if (*this_elem != *other_elem)
4822                             RETPUSHNO;
4823                     }
4824                     else {
4825                         (void)hv_store_ent(seen_this,
4826                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4827                                 &PL_sv_undef, 0);
4828                         (void)hv_store_ent(seen_other,
4829                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4830                                 &PL_sv_undef, 0);
4831                         PUSHs(*other_elem);
4832                         PUSHs(*this_elem);
4833
4834                         PUTBACK;
4835                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4836                         (void) do_smartmatch(seen_this, seen_other, 0);
4837                         SPAGAIN;
4838                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4839
4840                         if (!SvTRUEx(POPs))
4841                             RETPUSHNO;
4842                     }
4843                 }
4844                 RETPUSHYES;
4845             }
4846         }
4847         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4848             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4849           sm_regex_array:
4850             {
4851                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4852                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4853                 SSize_t i;
4854
4855                 for(i = 0; i <= this_len; ++i) {
4856                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4857                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4858                     PUTBACK;
4859                     if (svp && matcher_matches_sv(matcher, *svp)) {
4860                         SPAGAIN;
4861                         destroy_matcher(matcher);
4862                         RETPUSHYES;
4863                     }
4864                     SPAGAIN;
4865                 }
4866                 destroy_matcher(matcher);
4867                 RETPUSHNO;
4868             }
4869         }
4870         else if (!SvOK(d)) {
4871             /* undef ~~ array */
4872             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4873             SSize_t i;
4874
4875             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4876             for (i = 0; i <= this_len; ++i) {
4877                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4878                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4879                 if (!svp || !SvOK(*svp))
4880                     RETPUSHYES;
4881             }
4882             RETPUSHNO;
4883         }
4884         else {
4885           sm_any_array:
4886             {
4887                 SSize_t i;
4888                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4889
4890                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4891                 for (i = 0; i <= this_len; ++i) {
4892                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4893                     if (!svp)
4894                         continue;
4895
4896                     PUSHs(d);
4897                     PUSHs(*svp);
4898                     PUTBACK;
4899                     /* infinite recursion isn't supposed to happen here */
4900                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4901                     (void) do_smartmatch(NULL, NULL, 1);
4902                     SPAGAIN;
4903                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4904                     if (SvTRUEx(POPs))
4905                         RETPUSHYES;
4906                 }
4907                 RETPUSHNO;
4908             }
4909         }
4910     }
4911     /* ~~ qr// */
4912     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4913         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4914             SV *t = d; d = e; e = t;
4915             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4916             goto sm_regex_hash;
4917         }
4918         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4919             SV *t = d; d = e; e = t;
4920             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4921             goto sm_regex_array;
4922         }
4923         else {
4924             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4925             bool result;
4926
4927             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4928             PUTBACK;
4929             result = matcher_matches_sv(matcher, d);
4930             SPAGAIN;
4931             PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4932             destroy_matcher(matcher);
4933             RETURN;
4934         }
4935     }
4936     /* ~~ scalar */
4937     /* See if there is overload magic on left */
4938     else if (object_on_left && SvAMAGIC(d)) {
4939         SV *tmpsv;
4940         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4941         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4942         PUSHs(d); PUSHs(e);
4943         PUTBACK;
4944         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4945         if (tmpsv) {
4946             SPAGAIN;
4947             (void)POPs;
4948             SETs(tmpsv);
4949             RETURN;
4950         }
4951         SP -= 2;
4952         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4953         goto sm_any_scalar;
4954     }
4955     else if (!SvOK(d)) {
4956         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4957         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4958         RETPUSHNO;
4959     }
4960     else
4961   sm_any_scalar:
4962     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4963         DEBUG_M(if (SvNIOK(e))
4964                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4965                 else
4966                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4967         );
4968         /* numeric comparison */
4969         PUSHs(d); PUSHs(e);
4970         PUTBACK;
4971         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4972             (void) Perl_pp_i_eq(aTHX);
4973         else
4974             (void) Perl_pp_eq(aTHX);
4975         SPAGAIN;
4976         if (SvTRUEx(POPs))
4977             RETPUSHYES;
4978         else
4979             RETPUSHNO;
4980     }
4981
4982     /* As a last resort, use string comparison */
4983     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4984     PUSHs(d); PUSHs(e);
4985     PUTBACK;
4986     return Perl_pp_seq(aTHX);
4987 }
4988
4989 PP(pp_enterwhen)
4990 {
4991     dSP;
4992     PERL_CONTEXT *cx;
4993     const U8 gimme = GIMME_V;
4994
4995     /* This is essentially an optimization: if the match
4996        fails, we don't want to push a context and then
4997        pop it again right away, so we skip straight
4998        to the op that follows the leavewhen.
4999        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5000     */
5001     if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
5002         RETURNOP(cLOGOP->op_other->op_next);
5003
5004     cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5005     cx_pushwhen(cx);
5006
5007     RETURN;
5008 }
5009
5010 PP(pp_leavewhen)
5011 {
5012     I32 cxix;
5013     PERL_CONTEXT *cx;
5014     U8 gimme;
5015     SV **oldsp;
5016
5017     cx = CX_CUR();
5018     assert(CxTYPE(cx) == CXt_WHEN);
5019     gimme = cx->blk_gimme;
5020
5021     cxix = dopoptogivenfor(cxstack_ix);
5022     if (cxix < 0)
5023         /* diag_listed_as: Can't "when" outside a topicalizer */
5024         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5025                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5026
5027     oldsp = PL_stack_base + cx->blk_oldsp;
5028     if (gimme == G_VOID)
5029         PL_stack_sp = oldsp;
5030     else
5031         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5032
5033     /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5034     assert(cxix < cxstack_ix);
5035     dounwind(cxix);
5036
5037     cx = &cxstack[cxix];
5038
5039     if (CxFOREACH(cx)) {
5040         /* emulate pp_next. Note that any stack(s) cleanup will be
5041          * done by the pp_unstack which op_nextop should point to */
5042         cx = CX_CUR();
5043         cx_topblock(cx);
5044         PL_curcop = cx->blk_oldcop;
5045         return cx->blk_loop.my_op->op_nextop;
5046     }
5047     else {
5048         PERL_ASYNC_CHECK();
5049         assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5050         return cx->blk_givwhen.leave_op;
5051     }
5052 }
5053
5054 PP(pp_continue)
5055 {
5056     I32 cxix;
5057     PERL_CONTEXT *cx;
5058     OP *nextop;
5059
5060     cxix = dopoptowhen(cxstack_ix);
5061     if (cxix < 0)
5062         DIE(aTHX_ "Can't \"continue\" outside a when block");
5063
5064     if (cxix < cxstack_ix)
5065         dounwind(cxix);
5066
5067     cx = CX_CUR();
5068     assert(CxTYPE(cx) == CXt_WHEN);
5069     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5070     CX_LEAVE_SCOPE(cx);
5071     cx_popwhen(cx);
5072     cx_popblock(cx);
5073     nextop = cx->blk_givwhen.leave_op->op_next;
5074     CX_POP(cx);
5075
5076     return nextop;
5077 }
5078
5079 PP(pp_break)
5080 {
5081     I32 cxix;
5082     PERL_CONTEXT *cx;
5083
5084     cxix = dopoptogivenfor(cxstack_ix);
5085     if (cxix < 0)
5086         DIE(aTHX_ "Can't \"break\" outside a given block");
5087
5088     cx = &cxstack[cxix];
5089     if (CxFOREACH(cx))
5090         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5091
5092     if (cxix < cxstack_ix)
5093         dounwind(cxix);
5094
5095     /* Restore the sp at the time we entered the given block */
5096     cx = CX_CUR();
5097     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5098
5099     return cx->blk_givwhen.leave_op;
5100 }
5101
5102 static MAGIC *
5103 S_doparseform(pTHX_ SV *sv)
5104 {
5105     STRLEN len;
5106     char *s = SvPV(sv, len);
5107     char *send;
5108     char *base = NULL; /* start of current field */
5109     I32 skipspaces = 0; /* number of contiguous spaces seen */
5110     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5111     bool repeat    = FALSE; /* ~~ seen on this line */
5112     bool postspace = FALSE; /* a text field may need right padding */
5113     U32 *fops;
5114     U32 *fpc;
5115     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5116     I32 arg;
5117     bool ischop;            /* it's a ^ rather than a @ */
5118     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5119     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5120     MAGIC *mg = NULL;
5121     SV *sv_copy;
5122
5123     PERL_ARGS_ASSERT_DOPARSEFORM;
5124
5125     if (len == 0)
5126         Perl_croak(aTHX_ "Null picture in formline");
5127
5128     if (SvTYPE(sv) >= SVt_PVMG) {
5129         /* This might, of course, still return NULL.  */
5130         mg = mg_find(sv, PERL_MAGIC_fm);
5131     } else {
5132         sv_upgrade(sv, SVt_PVMG);
5133     }
5134
5135     if (mg) {
5136         /* still the same as previously-compiled string? */
5137         SV *old = mg->mg_obj;
5138         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5139               && len == SvCUR(old)
5140               && strnEQ(SvPVX(old), SvPVX(sv), len)
5141         ) {
5142             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5143             return mg;
5144         }
5145
5146         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5147         Safefree(mg->mg_ptr);
5148         mg->mg_ptr = NULL;
5149         SvREFCNT_dec(old);
5150         mg->mg_obj = NULL;
5151     }
5152     else {
5153         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5154         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5155     }
5156
5157     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5158     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5159     send = s + len;
5160
5161
5162     /* estimate the buffer size needed */
5163     for (base = s; s <= send; s++) {
5164         if (*s == '\n' || *s == '@' || *s == '^')
5165             maxops += 10;
5166     }
5167     s = base;
5168     base = NULL;
5169
5170     Newx(fops, maxops, U32);
5171     fpc = fops;
5172
5173     if (s < send) {
5174         linepc = fpc;
5175         *fpc++ = FF_LINEMARK;
5176         noblank = repeat = FALSE;
5177         base = s;
5178     }
5179
5180     while (s <= send) {
5181         switch (*s++) {
5182         default:
5183             skipspaces = 0;
5184             continue;
5185
5186         case '~':
5187             if (*s == '~') {
5188                 repeat = TRUE;
5189                 skipspaces++;
5190                 s++;
5191             }
5192             noblank = TRUE;
5193             /* FALLTHROUGH */
5194         case ' ': case '\t':
5195             skipspaces++;
5196             continue;
5197         case 0:
5198             if (s < send) {
5199                 skipspaces = 0;
5200                 continue;
5201             } /* else FALL THROUGH */
5202         case '\n':
5203             arg = s - base;
5204             skipspaces++;
5205             arg -= skipspaces;
5206             if (arg) {
5207                 if (postspace)
5208                     *fpc++ = FF_SPACE;
5209                 *fpc++ = FF_LITERAL;
5210                 *fpc++ = (U32)arg;
5211             }
5212             postspace = FALSE;
5213             if (s <= send)
5214                 skipspaces--;
5215             if (skipspaces) {
5216                 *fpc++ = FF_SKIP;
5217                 *fpc++ = (U32)skipspaces;
5218             }
5219             skipspaces = 0;
5220             if (s <= send)
5221                 *fpc++ = FF_NEWLINE;
5222             if (noblank) {
5223                 *fpc++ = FF_BLANK;
5224                 if (repeat)
5225                     arg = fpc - linepc + 1;
5226                 else
5227                     arg = 0;
5228                 *fpc++ = (U32)arg;
5229             }
5230             if (s < send) {
5231                 linepc = fpc;
5232                 *fpc++ = FF_LINEMARK;
5233                 noblank = repeat = FALSE;
5234                 base = s;
5235             }
5236             else
5237                 s++;
5238             continue;
5239
5240         case '@':
5241         case '^':
5242             ischop = s[-1] == '^';
5243
5244             if (postspace) {
5245                 *fpc++ = FF_SPACE;
5246                 postspace = FALSE;
5247             }
5248             arg = (s - base) - 1;
5249             if (arg) {
5250                 *fpc++ = FF_LITERAL;
5251                 *fpc++ = (U32)arg;
5252             }
5253
5254             base = s - 1;
5255             *fpc++ = FF_FETCH;
5256             if (*s == '*') { /*  @* or ^*  */
5257                 s++;
5258                 *fpc++ = 2;  /* skip the @* or ^* */
5259                 if (ischop) {
5260                     *fpc++ = FF_LINESNGL;
5261                     *fpc++ = FF_CHOP;
5262                 } else
5263                     *fpc++ = FF_LINEGLOB;
5264             }
5265             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5266                 arg = ischop ? FORM_NUM_BLANK : 0;
5267                 base = s - 1;
5268                 while (*s == '#')
5269                     s++;
5270                 if (*s == '.') {
5271                     const char * const f = ++s;
5272                     while (*s == '#')
5273                         s++;
5274                     arg |= FORM_NUM_POINT + (s - f);
5275                 }
5276                 *fpc++ = s - base;              /* fieldsize for FETCH */
5277                 *fpc++ = FF_DECIMAL;
5278                 *fpc++ = (U32)arg;
5279                 unchopnum |= ! ischop;
5280             }
5281             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5282                 arg = ischop ? FORM_NUM_BLANK : 0;
5283                 base = s - 1;
5284                 s++;                                /* skip the '0' first */
5285                 while (*s == '#')
5286                     s++;
5287                 if (*s == '.') {
5288                     const char * const f = ++s;
5289                     while (*s == '#')
5290                         s++;
5291                     arg |= FORM_NUM_POINT + (s - f);
5292                 }
5293                 *fpc++ = s - base;                /* fieldsize for FETCH */
5294                 *fpc++ = FF_0DECIMAL;
5295                 *fpc++ = (U32)arg;
5296                 unchopnum |= ! ischop;
5297             }
5298             else {                              /* text field */
5299                 I32 prespace = 0;
5300                 bool ismore = FALSE;
5301
5302                 if (*s == '>') {
5303                     while (*++s == '>') ;
5304                     prespace = FF_SPACE;
5305                 }
5306                 else if (*s == '|') {
5307                     while (*++s == '|') ;
5308                     prespace = FF_HALFSPACE;
5309                     postspace = TRUE;
5310                 }
5311                 else {
5312                     if (*s == '<')
5313                         while (*++s == '<') ;
5314                     postspace = TRUE;
5315                 }
5316                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5317                     s += 3;
5318                     ismore = TRUE;
5319                 }
5320                 *fpc++ = s - base;              /* fieldsize for FETCH */
5321
5322                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5323
5324                 if (prespace)
5325                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5326                 *fpc++ = FF_ITEM;
5327                 if (ismore)
5328                     *fpc++ = FF_MORE;
5329                 if (ischop)
5330                     *fpc++ = FF_CHOP;
5331             }
5332             base = s;
5333             skipspaces = 0;
5334             continue;
5335         }
5336     }
5337     *fpc++ = FF_END;
5338
5339     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5340     arg = fpc - fops;
5341
5342     mg->mg_ptr = (char *) fops;
5343     mg->mg_len = arg * sizeof(U32);
5344     mg->mg_obj = sv_copy;
5345     mg->mg_flags |= MGf_REFCOUNTED;
5346
5347     if (unchopnum && repeat)
5348         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5349
5350     return mg;
5351 }
5352
5353
5354 STATIC bool
5355 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5356 {
5357     /* Can value be printed in fldsize chars, using %*.*f ? */
5358     NV pwr = 1;
5359     NV eps = 0.5;
5360     bool res = FALSE;
5361     int intsize = fldsize - (value < 0 ? 1 : 0);
5362
5363     if (frcsize & FORM_NUM_POINT)
5364         intsize--;
5365     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5366     intsize -= frcsize;
5367
5368     while (intsize--) pwr *= 10.0;
5369     while (frcsize--) eps /= 10.0;
5370
5371     if( value >= 0 ){
5372         if (value + eps >= pwr)
5373             res = TRUE;
5374     } else {
5375         if (value - eps <= -pwr)
5376             res = TRUE;
5377     }
5378     return res;
5379 }
5380
5381 static I32
5382 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5383 {
5384     SV * const datasv = FILTER_DATA(idx);
5385     const int filter_has_file = IoLINES(datasv);
5386     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5387     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5388     int status = 0;
5389     SV *upstream;
5390     STRLEN got_len;
5391     char *got_p = NULL;
5392     char *prune_from = NULL;
5393     bool read_from_cache = FALSE;
5394     STRLEN umaxlen;
5395     SV *err = NULL;
5396
5397     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5398
5399     assert(maxlen >= 0);
5400     umaxlen = maxlen;
5401
5402     /* I was having segfault trouble under Linux 2.2.5 after a
5403        parse error occurred.  (Had to hack around it with a test
5404        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5405        not sure where the trouble is yet.  XXX */
5406
5407     {
5408         SV *const cache = datasv;
5409         if (SvOK(cache)) {
5410             STRLEN cache_len;
5411             const char *cache_p = SvPV(cache, cache_len);
5412             STRLEN take = 0;
5413
5414             if (umaxlen) {
5415                 /* Running in block mode and we have some cached data already.
5416                  */
5417                 if (cache_len >= umaxlen) {
5418                     /* In fact, so much data we don't even need to call
5419                        filter_read.  */
5420                     take = umaxlen;
5421                 }
5422             } else {
5423                 const char *const first_nl =
5424                     (const char *)memchr(cache_p, '\n', cache_len);
5425                 if (first_nl) {
5426                     take = first_nl + 1 - cache_p;
5427                 }
5428             }
5429             if (take) {
5430                 sv_catpvn(buf_sv, cache_p, take);
5431                 sv_chop(cache, cache_p + take);
5432                 /* Definitely not EOF  */
5433                 return 1;
5434             }
5435
5436             sv_catsv(buf_sv, cache);
5437             if (umaxlen) {
5438                 umaxlen -= cache_len;
5439             }
5440             SvOK_off(cache);
5441             read_from_cache = TRUE;
5442         }
5443     }
5444
5445     /* Filter API says that the filter appends to the contents of the buffer.
5446        Usually the buffer is "", so the details don't matter. But if it's not,
5447        then clearly what it contains is already filtered by this filter, so we
5448        don't want to pass it in a second time.
5449        I'm going to use a mortal in case the upstream filter croaks.  */
5450     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5451         ? sv_newmortal() : buf_sv;
5452     SvUPGRADE(upstream, SVt_PV);
5453
5454     if (filter_has_file) {
5455         status = FILTER_READ(idx+1, upstream, 0);
5456     }
5457
5458     if (filter_sub && status >= 0) {
5459         dSP;
5460         int count;
5461
5462         ENTER_with_name("call_filter_sub");
5463         SAVE_DEFSV;
5464         SAVETMPS;
5465         EXTEND(SP, 2);
5466
5467         DEFSV_set(upstream);
5468         PUSHMARK(SP);
5469         mPUSHi(0);
5470         if (filter_state) {
5471             PUSHs(filter_state);
5472         }
5473         PUTBACK;
5474         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5475         SPAGAIN;
5476
5477         if (count > 0) {
5478             SV *out = POPs;
5479             SvGETMAGIC(out);
5480             if (SvOK(out)) {
5481                 status = SvIV(out);
5482             }
5483             else {
5484                 SV * const errsv = ERRSV;
5485                 if (SvTRUE_NN(errsv))
5486                     err = newSVsv(errsv);
5487             }
5488         }
5489
5490         PUTBACK;
5491         FREETMPS;
5492         LEAVE_with_name("call_filter_sub");
5493     }
5494
5495     if (SvGMAGICAL(upstream)) {
5496         mg_get(upstream);
5497         if (upstream == buf_sv) mg_free(buf_sv);
5498     }
5499     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5500     if(!err && SvOK(upstream)) {
5501         got_p = SvPV_nomg(upstream, got_len);
5502         if (umaxlen) {
5503             if (got_len > umaxlen) {
5504                 prune_from = got_p + umaxlen;
5505             }
5506         } else {
5507             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5508             if (first_nl && first_nl + 1 < got_p + got_len) {
5509                 /* There's a second line here... */
5510                 prune_from = first_nl + 1;
5511             }
5512         }
5513     }
5514     if (!err && prune_from) {
5515         /* Oh. Too long. Stuff some in our cache.  */
5516         STRLEN cached_len = got_p + got_len - prune_from;
5517         SV *const cache = datasv;
5518
5519         if (SvOK(cache)) {
5520             /* Cache should be empty.  */
5521             assert(!SvCUR(cache));
5522         }
5523
5524         sv_setpvn(cache, prune_from, cached_len);
5525         /* If you ask for block mode, you may well split UTF-8 characters.
5526            "If it breaks, you get to keep both parts"
5527            (Your code is broken if you  don't put them back together again
5528            before something notices.) */
5529         if (SvUTF8(upstream)) {
5530             SvUTF8_on(cache);
5531         }
5532         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5533         else
5534             /* Cannot just use sv_setpvn, as that could free the buffer
5535                before we have a chance to assign it. */
5536             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5537                       got_len - cached_len);
5538         *prune_from = 0;
5539         /* Can't yet be EOF  */
5540         if (status == 0)
5541             status = 1;
5542     }
5543
5544     /* If they are at EOF but buf_sv has something in it, then they may never
5545        have touched the SV upstream, so it may be undefined.  If we naively
5546        concatenate it then we get a warning about use of uninitialised value.
5547     */
5548     if (!err && upstream != buf_sv &&
5549         SvOK(upstream)) {
5550         sv_catsv_nomg(buf_sv, upstream);
5551     }
5552     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5553
5554     if (status <= 0) {
5555         IoLINES(datasv) = 0;
5556         if (filter_state) {
5557             SvREFCNT_dec(filter_state);
5558             IoTOP_GV(datasv) = NULL;
5559         }
5560         if (filter_sub) {
5561             SvREFCNT_dec(filter_sub);
5562             IoBOTTOM_GV(datasv) = NULL;
5563         }
5564         filter_del(S_run_user_filter);
5565     }
5566
5567     if (err)
5568         croak_sv(err);
5569
5570     if (status == 0 && read_from_cache) {
5571         /* If we read some data from the cache (and by getting here it implies
5572            that we emptied the cache) then we aren't yet at EOF, and mustn't
5573            report that to our caller.  */
5574         return 1;
5575     }
5576     return status;
5577 }
5578
5579 /*
5580  * ex: set ts=8 sts=4 sw=4 et:
5581  */