pp_ctl.c

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