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