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_private & OPpTARGET_MY)
 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 I32 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             assert(0); /* 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             {
 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                 if (!len)
 705                     break;
 706                 trans = 0;
 707                 gotsome = TRUE;
 708                 chophere = s + len;
 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 == 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 == 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 == 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             }
1215         }
1216         else {
1217             STRLEN len, llen;
1218             const char * const lpv = SvPV_nomg_const(left, llen);
1219             const char * const tmps = SvPV_nomg_const(right, len);
1220
1221             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1222             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1223                 XPUSHs(sv);
1224                 if (strEQ(SvPVX_const(sv),tmps))
1225                     break;
1226                 sv = sv_2mortal(newSVsv(sv));
1227                 sv_inc(sv);
1228             }
1229         }
1230     }
1231     else {
1232         dTOPss;
1233         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1234         int flop = 0;
1235         sv_inc(targ);
1236
1237         if (PL_op->op_private & OPpFLIP_LINENUM) {
1238             if (GvIO(PL_last_in_gv)) {
1239                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1240             }
1241             else {
1242                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1243                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1244             }
1245         }
1246         else {
1247             flop = SvTRUE(sv);
1248         }
1249
1250         if (flop) {
1251             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1252             sv_catpvs(targ, "E0");
1253         }
1254         SETs(targ);
1255     }
1256
1257     RETURN;
1258 }
1259
1260 /* Control. */
1261
1262 static const char * const context_name[] = {
1263     "pseudo-block",
1264     NULL, /* CXt_WHEN never actually needs "block" */
1265     NULL, /* CXt_BLOCK never actually needs "block" */
1266     NULL, /* CXt_GIVEN never actually needs "block" */
1267     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1268     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1269     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1270     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1271     "subroutine",
1272     "format",
1273     "eval",
1274     "substitution",
1275 };
1276
1277 STATIC I32
1278 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1279 {
1280     I32 i;
1281
1282     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1283
1284     for (i = cxstack_ix; i >= 0; i--) {
1285         const PERL_CONTEXT * const cx = &cxstack[i];
1286         switch (CxTYPE(cx)) {
1287         case CXt_SUBST:
1288         case CXt_SUB:
1289         case CXt_FORMAT:
1290         case CXt_EVAL:
1291         case CXt_NULL:
1292             /* diag_listed_as: Exiting subroutine via %s */
1293             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1294                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1295             if (CxTYPE(cx) == CXt_NULL)
1296                 return -1;
1297             break;
1298         case CXt_LOOP_LAZYIV:
1299         case CXt_LOOP_LAZYSV:
1300         case CXt_LOOP_FOR:
1301         case CXt_LOOP_PLAIN:
1302           {
1303             STRLEN cx_label_len = 0;
1304             U32 cx_label_flags = 0;
1305             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1306             if (!cx_label || !(
1307                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1308                         (flags & SVf_UTF8)
1309                             ? (bytes_cmp_utf8(
1310                                         (const U8*)cx_label, cx_label_len,
1311                                         (const U8*)label, len) == 0)
1312                             : (bytes_cmp_utf8(
1313                                         (const U8*)label, len,
1314                                         (const U8*)cx_label, cx_label_len) == 0)
1315                     : (len == cx_label_len && ((cx_label == label)
1316                                     || memEQ(cx_label, label, len))) )) {
1317                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1318                         (long)i, cx_label));
1319                 continue;
1320             }
1321             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1322             return i;
1323           }
1324         }
1325     }
1326     return i;
1327 }
1328
1329
1330
1331 I32
1332 Perl_dowantarray(pTHX)
1333 {
1334     const I32 gimme = block_gimme();
1335     return (gimme == G_VOID) ? G_SCALAR : gimme;
1336 }
1337
1338 I32
1339 Perl_block_gimme(pTHX)
1340 {
1341     const I32 cxix = dopoptosub(cxstack_ix);
1342     if (cxix < 0)
1343         return G_VOID;
1344
1345     switch (cxstack[cxix].blk_gimme) {
1346     case G_VOID:
1347         return G_VOID;
1348     case G_SCALAR:
1349         return G_SCALAR;
1350     case G_ARRAY:
1351         return G_ARRAY;
1352     default:
1353         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1354     }
1355     NOT_REACHED; /* NOTREACHED */
1356 }
1357
1358 I32
1359 Perl_is_lvalue_sub(pTHX)
1360 {
1361     const I32 cxix = dopoptosub(cxstack_ix);
1362     assert(cxix >= 0);  /* We should only be called from inside subs */
1363
1364     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1365         return CxLVAL(cxstack + cxix);
1366     else
1367         return 0;
1368 }
1369
1370 /* only used by PUSHSUB */
1371 I32
1372 Perl_was_lvalue_sub(pTHX)
1373 {
1374     const I32 cxix = dopoptosub(cxstack_ix-1);
1375     assert(cxix >= 0);  /* We should only be called from inside subs */
1376
1377     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1378         return CxLVAL(cxstack + cxix);
1379     else
1380         return 0;
1381 }
1382
1383 STATIC I32
1384 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1385 {
1386     I32 i;
1387
1388     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1389 #ifndef DEBUGGING
1390     PERL_UNUSED_CONTEXT;
1391 #endif
1392
1393     for (i = startingblock; i >= 0; i--) {
1394         const PERL_CONTEXT * const cx = &cxstk[i];
1395         switch (CxTYPE(cx)) {
1396         default:
1397             continue;
1398         case CXt_SUB:
1399             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1400              * twice; the first for the normal foo() call, and the second
1401              * for a faked up re-entry into the sub to execute the
1402              * code block. Hide this faked entry from the world. */
1403             if (cx->cx_type & CXp_SUB_RE_FAKE)
1404                 continue;
1405             /* FALLTHROUGH */
1406         case CXt_EVAL:
1407         case CXt_FORMAT:
1408             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1409             return i;
1410         }
1411     }
1412     return i;
1413 }
1414
1415 STATIC I32
1416 S_dopoptoeval(pTHX_ I32 startingblock)
1417 {
1418     I32 i;
1419     for (i = startingblock; i >= 0; i--) {
1420         const PERL_CONTEXT *cx = &cxstack[i];
1421         switch (CxTYPE(cx)) {
1422         default:
1423             continue;
1424         case CXt_EVAL:
1425             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1426             return i;
1427         }
1428     }
1429     return i;
1430 }
1431
1432 STATIC I32
1433 S_dopoptoloop(pTHX_ I32 startingblock)
1434 {
1435     I32 i;
1436     for (i = startingblock; i >= 0; i--) {
1437         const PERL_CONTEXT * const cx = &cxstack[i];
1438         switch (CxTYPE(cx)) {
1439         case CXt_SUBST:
1440         case CXt_SUB:
1441         case CXt_FORMAT:
1442         case CXt_EVAL:
1443         case CXt_NULL:
1444             /* diag_listed_as: Exiting subroutine via %s */
1445             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1446                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1447             if ((CxTYPE(cx)) == CXt_NULL)
1448                 return -1;
1449             break;
1450         case CXt_LOOP_LAZYIV:
1451         case CXt_LOOP_LAZYSV:
1452         case CXt_LOOP_FOR:
1453         case CXt_LOOP_PLAIN:
1454             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1455             return i;
1456         }
1457     }
1458     return i;
1459 }
1460
1461 STATIC I32
1462 S_dopoptogiven(pTHX_ I32 startingblock)
1463 {
1464     I32 i;
1465     for (i = startingblock; i >= 0; i--) {
1466         const PERL_CONTEXT *cx = &cxstack[i];
1467         switch (CxTYPE(cx)) {
1468         default:
1469             continue;
1470         case CXt_GIVEN:
1471             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1472             return i;
1473         case CXt_LOOP_PLAIN:
1474             assert(!CxFOREACHDEF(cx));
1475             break;
1476         case CXt_LOOP_LAZYIV:
1477         case CXt_LOOP_LAZYSV:
1478         case CXt_LOOP_FOR:
1479             if (CxFOREACHDEF(cx)) {
1480                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1481                 return i;
1482             }
1483         }
1484     }
1485     return i;
1486 }
1487
1488 STATIC I32
1489 S_dopoptowhen(pTHX_ I32 startingblock)
1490 {
1491     I32 i;
1492     for (i = startingblock; i >= 0; i--) {
1493         const PERL_CONTEXT *cx = &cxstack[i];
1494         switch (CxTYPE(cx)) {
1495         default:
1496             continue;
1497         case CXt_WHEN:
1498             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1499             return i;
1500         }
1501     }
1502     return i;
1503 }
1504
1505 void
1506 Perl_dounwind(pTHX_ I32 cxix)
1507 {
1508     I32 optype;
1509
1510     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1511         return;
1512
1513     while (cxstack_ix > cxix) {
1514         SV *sv;
1515         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1516         DEBUG_CX("UNWIND");                                             \
1517         /* Note: we don't need to restore the base context info till the end. */
1518         switch (CxTYPE(cx)) {
1519         case CXt_SUBST:
1520             POPSUBST(cx);
1521             continue;  /* not break */
1522         case CXt_SUB:
1523             POPSUB(cx,sv);
1524             LEAVESUB(sv);
1525             break;
1526         case CXt_EVAL:
1527             POPEVAL(cx);
1528             break;
1529         case CXt_LOOP_LAZYIV:
1530         case CXt_LOOP_LAZYSV:
1531         case CXt_LOOP_FOR:
1532         case CXt_LOOP_PLAIN:
1533             POPLOOP(cx);
1534             break;
1535         case CXt_NULL:
1536             break;
1537         case CXt_FORMAT:
1538             POPFORMAT(cx);
1539             break;
1540         }
1541         cxstack_ix--;
1542     }
1543     PERL_UNUSED_VAR(optype);
1544 }
1545
1546 void
1547 Perl_qerror(pTHX_ SV *err)
1548 {
1549     PERL_ARGS_ASSERT_QERROR;
1550
1551     if (PL_in_eval) {
1552         if (PL_in_eval & EVAL_KEEPERR) {
1553                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1554                                                     SVfARG(err));
1555         }
1556         else
1557             sv_catsv(ERRSV, err);
1558     }
1559     else if (PL_errors)
1560         sv_catsv(PL_errors, err);
1561     else
1562         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1563     if (PL_parser)
1564         ++PL_parser->error_count;
1565 }
1566
1567 void
1568 Perl_die_unwind(pTHX_ SV *msv)
1569 {
1570     SV *exceptsv = sv_mortalcopy(msv);
1571     U8 in_eval = PL_in_eval;
1572     PERL_ARGS_ASSERT_DIE_UNWIND;
1573
1574     if (in_eval) {
1575         I32 cxix;
1576         I32 gimme;
1577
1578         /*
1579          * Historically, perl used to set ERRSV ($@) early in the die
1580          * process and rely on it not getting clobbered during unwinding.
1581          * That sucked, because it was liable to get clobbered, so the
1582          * setting of ERRSV used to emit the exception from eval{} has
1583          * been moved to much later, after unwinding (see just before
1584          * JMPENV_JUMP below).  However, some modules were relying on the
1585          * early setting, by examining $@ during unwinding to use it as
1586          * a flag indicating whether the current unwinding was caused by
1587          * an exception.  It was never a reliable flag for that purpose,
1588          * being totally open to false positives even without actual
1589          * clobberage, but was useful enough for production code to
1590          * semantically rely on it.
1591          *
1592          * We'd like to have a proper introspective interface that
1593          * explicitly describes the reason for whatever unwinding
1594          * operations are currently in progress, so that those modules
1595          * work reliably and $@ isn't further overloaded.  But we don't
1596          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1597          * now *additionally* set here, before unwinding, to serve as the
1598          * (unreliable) flag that it used to.
1599          *
1600          * This behaviour is temporary, and should be removed when a
1601          * proper way to detect exceptional unwinding has been developed.
1602          * As of 2010-12, the authors of modules relying on the hack
1603          * are aware of the issue, because the modules failed on
1604          * perls 5.13.{1..7} which had late setting of $@ without this
1605          * early-setting hack.
1606          */
1607         if (!(in_eval & EVAL_KEEPERR)) {
1608             SvTEMP_off(exceptsv);
1609             sv_setsv(ERRSV, exceptsv);
1610         }
1611
1612         if (in_eval & EVAL_KEEPERR) {
1613             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1614                            SVfARG(exceptsv));
1615         }
1616
1617         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1618                && PL_curstackinfo->si_prev)
1619         {
1620             dounwind(-1);
1621             POPSTACK;
1622         }
1623
1624         if (cxix >= 0) {
1625             I32 optype;
1626             SV *namesv;
1627             PERL_CONTEXT *cx;
1628             SV **newsp;
1629 #ifdef DEBUGGING
1630             COP *oldcop;
1631 #endif
1632             JMPENV *restartjmpenv;
1633             OP *restartop;
1634
1635             if (cxix < cxstack_ix)
1636                 dounwind(cxix);
1637
1638             POPBLOCK(cx,PL_curpm);
1639             if (CxTYPE(cx) != CXt_EVAL) {
1640                 STRLEN msglen;
1641                 const char* message = SvPVx_const(exceptsv, msglen);
1642                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1643                 PerlIO_write(Perl_error_log, message, msglen);
1644                 my_exit(1);
1645             }
1646             POPEVAL(cx);
1647             namesv = cx->blk_eval.old_namesv;
1648 #ifdef DEBUGGING
1649             oldcop = cx->blk_oldcop;
1650 #endif
1651             restartjmpenv = cx->blk_eval.cur_top_env;
1652             restartop = cx->blk_eval.retop;
1653
1654             if (gimme == G_SCALAR)
1655                 *++newsp = &PL_sv_undef;
1656             PL_stack_sp = newsp;
1657
1658             LEAVE;
1659
1660             if (optype == OP_REQUIRE) {
1661                 assert (PL_curcop == oldcop);
1662                 (void)hv_store(GvHVn(PL_incgv),
1663                                SvPVX_const(namesv),
1664                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1665                                &PL_sv_undef, 0);
1666                 /* note that unlike pp_entereval, pp_require isn't
1667                  * supposed to trap errors. So now that we've popped the
1668                  * EVAL that pp_require pushed, and processed the error
1669                  * message, rethrow the error */
1670                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1671                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1672                                                                     SVs_TEMP)));
1673             }
1674             if (!(in_eval & EVAL_KEEPERR))
1675                 sv_setsv(ERRSV, exceptsv);
1676             PL_restartjmpenv = restartjmpenv;
1677             PL_restartop = restartop;
1678             JMPENV_JUMP(3);
1679             assert(0); /* NOTREACHED */
1680         }
1681     }
1682
1683     write_to_stderr(exceptsv);
1684     my_failure_exit();
1685     assert(0); /* NOTREACHED */
1686 }
1687
1688 PP(pp_xor)
1689 {
1690     dSP; dPOPTOPssrl;
1691     if (SvTRUE(left) != SvTRUE(right))
1692         RETSETYES;
1693     else
1694         RETSETNO;
1695 }
1696
1697 /*
1698
1699 =head1 CV Manipulation Functions
1700
1701 =for apidoc caller_cx
1702
1703 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1704 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1705 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1706 stack frame, so C<caller_cx(0, NULL)> will return information for the
1707 immediately-surrounding Perl code.
1708
1709 This function skips over the automatic calls to C<&DB::sub> made on the
1710 behalf of the debugger.  If the stack frame requested was a sub called by
1711 C<DB::sub>, the return value will be the frame for the call to
1712 C<DB::sub>, since that has the correct line number/etc. for the call
1713 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1714 frame for the sub call itself.
1715
1716 =cut
1717 */
1718
1719 const PERL_CONTEXT *
1720 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1721 {
1722     I32 cxix = dopoptosub(cxstack_ix);
1723     const PERL_CONTEXT *cx;
1724     const PERL_CONTEXT *ccstack = cxstack;
1725     const PERL_SI *top_si = PL_curstackinfo;
1726
1727     for (;;) {
1728         /* we may be in a higher stacklevel, so dig down deeper */
1729         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1730             top_si = top_si->si_prev;
1731             ccstack = top_si->si_cxstack;
1732             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1733         }
1734         if (cxix < 0)
1735             return NULL;
1736         /* caller() should not report the automatic calls to &DB::sub */
1737         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1738                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1739             count++;
1740         if (!count--)
1741             break;
1742         cxix = dopoptosub_at(ccstack, cxix - 1);
1743     }
1744
1745     cx = &ccstack[cxix];
1746     if (dbcxp) *dbcxp = cx;
1747
1748     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1749         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1750         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1751            field below is defined for any cx. */
1752         /* caller() should not report the automatic calls to &DB::sub */
1753         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1754             cx = &ccstack[dbcxix];
1755     }
1756
1757     return cx;
1758 }
1759
1760 PP(pp_caller)
1761 {
1762     dSP;
1763     const PERL_CONTEXT *cx;
1764     const PERL_CONTEXT *dbcx;
1765     I32 gimme;
1766     const HEK *stash_hek;
1767     I32 count = 0;
1768     bool has_arg = MAXARG && TOPs;
1769     const COP *lcop;
1770
1771     if (MAXARG) {
1772       if (has_arg)
1773         count = POPi;
1774       else (void)POPs;
1775     }
1776
1777     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1778     if (!cx) {
1779         if (GIMME != G_ARRAY) {
1780             EXTEND(SP, 1);
1781             RETPUSHUNDEF;
1782         }
1783         RETURN;
1784     }
1785
1786     DEBUG_CX("CALLER");
1787     assert(CopSTASH(cx->blk_oldcop));
1788     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1789       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1790       : NULL;
1791     if (GIMME != G_ARRAY) {
1792         EXTEND(SP, 1);
1793         if (!stash_hek)
1794             PUSHs(&PL_sv_undef);
1795         else {
1796             dTARGET;
1797             sv_sethek(TARG, stash_hek);
1798             PUSHs(TARG);
1799         }
1800         RETURN;
1801     }
1802
1803     EXTEND(SP, 11);
1804
1805     if (!stash_hek)
1806         PUSHs(&PL_sv_undef);
1807     else {
1808         dTARGET;
1809         sv_sethek(TARG, stash_hek);
1810         PUSHTARG;
1811     }
1812     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1813     lcop = closest_cop(cx->blk_oldcop, OP_SIBLING(cx->blk_oldcop),
1814                        cx->blk_sub.retop, TRUE);
1815     if (!lcop)
1816         lcop = cx->blk_oldcop;
1817     mPUSHi((I32)CopLINE(lcop));
1818     if (!has_arg)
1819         RETURN;
1820     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1821         /* So is ccstack[dbcxix]. */
1822         if (CvHASGV(dbcx->blk_sub.cv)) {
1823             PUSHs(cv_name(dbcx->blk_sub.cv, 0));
1824             PUSHs(boolSV(CxHASARGS(cx)));
1825         }
1826         else {
1827             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1828             PUSHs(boolSV(CxHASARGS(cx)));
1829         }
1830     }
1831     else {
1832         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1833         mPUSHi(0);
1834     }
1835     gimme = (I32)cx->blk_gimme;
1836     if (gimme == G_VOID)
1837         PUSHs(&PL_sv_undef);
1838     else
1839         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1840     if (CxTYPE(cx) == CXt_EVAL) {
1841         /* eval STRING */
1842         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1843             SV *cur_text = cx->blk_eval.cur_text;
1844             if (SvCUR(cur_text) >= 2) {
1845                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1846                                      SvUTF8(cur_text)|SVs_TEMP));
1847             }
1848             else {
1849                 /* I think this is will always be "", but be sure */
1850                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1851             }
1852
1853             PUSHs(&PL_sv_no);
1854         }
1855         /* require */
1856         else if (cx->blk_eval.old_namesv) {
1857             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1858             PUSHs(&PL_sv_yes);
1859         }
1860         /* eval BLOCK (try blocks have old_namesv == 0) */
1861         else {
1862             PUSHs(&PL_sv_undef);
1863             PUSHs(&PL_sv_undef);
1864         }
1865     }
1866     else {
1867         PUSHs(&PL_sv_undef);
1868         PUSHs(&PL_sv_undef);
1869     }
1870     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1871         && CopSTASH_eq(PL_curcop, PL_debstash))
1872     {
1873         AV * const ary = cx->blk_sub.argarray;
1874         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1875
1876         Perl_init_dbargs(aTHX);
1877
1878         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1879             av_extend(PL_dbargs, AvFILLp(ary) + off);
1880         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1881         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1882     }
1883     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1884     {
1885         SV * mask ;
1886         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1887
1888         if  (old_warnings == pWARN_NONE)
1889             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1890         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1891             mask = &PL_sv_undef ;
1892         else if (old_warnings == pWARN_ALL ||
1893                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1894             /* Get the bit mask for $warnings::Bits{all}, because
1895              * it could have been extended by warnings::register */
1896             SV **bits_all;
1897             HV * const bits = get_hv("warnings::Bits", 0);
1898             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1899                 mask = newSVsv(*bits_all);
1900             }
1901             else {
1902                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1903             }
1904         }
1905         else
1906             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1907         mPUSHs(mask);
1908     }
1909
1910     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1911           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1912           : &PL_sv_undef);
1913     RETURN;
1914 }
1915
1916 PP(pp_reset)
1917 {
1918     dSP;
1919     const char * tmps;
1920     STRLEN len = 0;
1921     if (MAXARG < 1 || (!TOPs && !POPs))
1922         tmps = NULL, len = 0;
1923     else
1924         tmps = SvPVx_const(POPs, len);
1925     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1926     PUSHs(&PL_sv_yes);
1927     RETURN;
1928 }
1929
1930 /* like pp_nextstate, but used instead when the debugger is active */
1931
1932 PP(pp_dbstate)
1933 {
1934     PL_curcop = (COP*)PL_op;
1935     TAINT_NOT;          /* Each statement is presumed innocent */
1936     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1937     FREETMPS;
1938
1939     PERL_ASYNC_CHECK();
1940
1941     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1942             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1943     {
1944         dSP;
1945         PERL_CONTEXT *cx;
1946         const I32 gimme = G_ARRAY;
1947         U8 hasargs;
1948         GV * const gv = PL_DBgv;
1949         CV * cv = NULL;
1950
1951         if (gv && isGV_with_GP(gv))
1952             cv = GvCV(gv);
1953
1954         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1955             DIE(aTHX_ "No DB::DB routine defined");
1956
1957         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1958             /* don't do recursive DB::DB call */
1959             return NORMAL;
1960
1961         ENTER;
1962         SAVETMPS;
1963
1964         SAVEI32(PL_debug);
1965         SAVESTACK_POS();
1966         PL_debug = 0;
1967         hasargs = 0;
1968         SPAGAIN;
1969
1970         if (CvISXSUB(cv)) {
1971             PUSHMARK(SP);
1972             (void)(*CvXSUB(cv))(aTHX_ cv);
1973             FREETMPS;
1974             LEAVE;
1975             return NORMAL;
1976         }
1977         else {
1978             PUSHBLOCK(cx, CXt_SUB, SP);
1979             PUSHSUB_DB(cx);
1980             cx->blk_sub.retop = PL_op->op_next;
1981             CvDEPTH(cv)++;
1982             if (CvDEPTH(cv) >= 2) {
1983                 PERL_STACK_OVERFLOW_CHECK();
1984                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1985             }
1986             SAVECOMPPAD();
1987             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1988             RETURNOP(CvSTART(cv));
1989         }
1990     }
1991     else
1992         return NORMAL;
1993 }
1994
1995 /* S_leave_common: Common code that many functions in this file use on
1996                    scope exit.  */
1997
1998 /* SVs on the stack that have any of the flags passed in are left as is.
1999    Other SVs are protected via the mortals stack if lvalue is true, and
2000    copied otherwise.
2001
2002    Also, taintedness is cleared.
2003 */
2004
2005 STATIC SV **
2006 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2007                               U32 flags, bool lvalue)
2008 {
2009     bool padtmp = 0;
2010     PERL_ARGS_ASSERT_LEAVE_COMMON;
2011
2012     TAINT_NOT;
2013     if (flags & SVs_PADTMP) {
2014         flags &= ~SVs_PADTMP;
2015         padtmp = 1;
2016     }
2017     if (gimme == G_SCALAR) {
2018         if (MARK < SP)
2019             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2020                             ? *SP
2021                             : lvalue
2022                                 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2023                                 : sv_mortalcopy(*SP);
2024         else {
2025             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2026             MARK = newsp;
2027             MEXTEND(MARK, 1);
2028             *++MARK = &PL_sv_undef;
2029             return MARK;
2030         }
2031     }
2032     else if (gimme == G_ARRAY) {
2033         /* in case LEAVE wipes old return values */
2034         while (++MARK <= SP) {
2035             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2036                 *++newsp = *MARK;
2037             else {
2038                 *++newsp = lvalue
2039                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2040                             : sv_mortalcopy(*MARK);
2041                 TAINT_NOT;      /* Each item is independent */
2042             }
2043         }
2044         /* When this function was called with MARK == newsp, we reach this
2045          * point with SP == newsp. */
2046     }
2047
2048     return newsp;
2049 }
2050
2051 PP(pp_enter)
2052 {
2053     dSP;
2054     PERL_CONTEXT *cx;
2055     I32 gimme = GIMME_V;
2056
2057     ENTER_with_name("block");
2058
2059     SAVETMPS;
2060     PUSHBLOCK(cx, CXt_BLOCK, SP);
2061
2062     RETURN;
2063 }
2064
2065 PP(pp_leave)
2066 {
2067     dSP;
2068     PERL_CONTEXT *cx;
2069     SV **newsp;
2070     PMOP *newpm;
2071     I32 gimme;
2072
2073     if (PL_op->op_flags & OPf_SPECIAL) {
2074         cx = &cxstack[cxstack_ix];
2075         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2076     }
2077
2078     POPBLOCK(cx,newpm);
2079
2080     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2081
2082     SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2083                                PL_op->op_private & OPpLVALUE);
2084     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2085
2086     LEAVE_with_name("block");
2087
2088     RETURN;
2089 }
2090
2091 PP(pp_enteriter)
2092 {
2093     dSP; dMARK;
2094     PERL_CONTEXT *cx;
2095     const I32 gimme = GIMME_V;
2096     void *itervar; /* location of the iteration variable */
2097     U8 cxtype = CXt_LOOP_FOR;
2098
2099     ENTER_with_name("loop1");
2100     SAVETMPS;
2101
2102     if (PL_op->op_targ) {                        /* "my" variable */
2103         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2104             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2105             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2106                     SVs_PADSTALE, SVs_PADSTALE);
2107         }
2108         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2109 #ifdef USE_ITHREADS
2110         itervar = PL_comppad;
2111 #else
2112         itervar = &PAD_SVl(PL_op->op_targ);
2113 #endif
2114     }
2115     else {                                      /* symbol table variable */
2116         GV * const gv = MUTABLE_GV(POPs);
2117         SV** svp = &GvSV(gv);
2118         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2119         *svp = newSV(0);
2120         itervar = (void *)gv;
2121     }
2122
2123     if (PL_op->op_private & OPpITER_DEF)
2124         cxtype |= CXp_FOR_DEF;
2125
2126     ENTER_with_name("loop2");
2127
2128     PUSHBLOCK(cx, cxtype, SP);
2129     PUSHLOOP_FOR(cx, itervar, MARK);
2130     if (PL_op->op_flags & OPf_STACKED) {
2131         SV *maybe_ary = POPs;
2132         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2133             dPOPss;
2134             SV * const right = maybe_ary;
2135             SvGETMAGIC(sv);
2136             SvGETMAGIC(right);
2137             if (RANGE_IS_NUMERIC(sv,right)) {
2138                 NV nv;
2139                 cx->cx_type &= ~CXTYPEMASK;
2140                 cx->cx_type |= CXt_LOOP_LAZYIV;
2141                 /* Make sure that no-one re-orders cop.h and breaks our
2142                    assumptions */
2143                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2144 #ifdef NV_PRESERVES_UV
2145                 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) ||
2146                                   (nv > (NV)IV_MAX)))
2147                         ||
2148                     (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) ||
2149                                      (nv < (NV)IV_MIN))))
2150 #else
2151                 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN)
2152                                   ||
2153                                   ((nv > 0) &&
2154                                         ((nv > (NV)UV_MAX) ||
2155                                          (SvUV_nomg(sv) > (UV)IV_MAX)))))
2156                         ||
2157                     (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN)
2158                                      ||
2159                                      ((nv > 0) &&
2160                                         ((nv > (NV)UV_MAX) ||
2161                                          (SvUV_nomg(right) > (UV)IV_MAX))
2162                                      ))))
2163 #endif
2164                     DIE(aTHX_ "Range iterator outside integer range");
2165                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2166                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2167 #ifdef DEBUGGING
2168                 /* for correct -Dstv display */
2169                 cx->blk_oldsp = sp - PL_stack_base;
2170 #endif
2171             }
2172             else {
2173                 cx->cx_type &= ~CXTYPEMASK;
2174                 cx->cx_type |= CXt_LOOP_LAZYSV;
2175                 /* Make sure that no-one re-orders cop.h and breaks our
2176                    assumptions */
2177                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2178                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2179                 cx->blk_loop.state_u.lazysv.end = right;
2180                 SvREFCNT_inc(right);
2181                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2182                 /* This will do the upgrade to SVt_PV, and warn if the value
2183                    is uninitialised.  */
2184                 (void) SvPV_nolen_const(right);
2185                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2186                    to replace !SvOK() with a pointer to "".  */
2187                 if (!SvOK(right)) {
2188                     SvREFCNT_dec(right);
2189                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2190                 }
2191             }
2192         }
2193         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2194             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2195             SvREFCNT_inc(maybe_ary);
2196             cx->blk_loop.state_u.ary.ix =
2197                 (PL_op->op_private & OPpITER_REVERSED) ?
2198                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2199                 -1;
2200         }
2201     }
2202     else { /* iterating over items on the stack */
2203         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2204         if (PL_op->op_private & OPpITER_REVERSED) {
2205             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2206         }
2207         else {
2208             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2209         }
2210     }
2211
2212     RETURN;
2213 }
2214
2215 PP(pp_enterloop)
2216 {
2217     dSP;
2218     PERL_CONTEXT *cx;
2219     const I32 gimme = GIMME_V;
2220
2221     ENTER_with_name("loop1");
2222     SAVETMPS;
2223     ENTER_with_name("loop2");
2224
2225     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2226     PUSHLOOP_PLAIN(cx, SP);
2227
2228     RETURN;
2229 }
2230
2231 PP(pp_leaveloop)
2232 {
2233     dSP;
2234     PERL_CONTEXT *cx;
2235     I32 gimme;
2236     SV **newsp;
2237     PMOP *newpm;
2238     SV **mark;
2239
2240     POPBLOCK(cx,newpm);
2241     assert(CxTYPE_is_LOOP(cx));
2242     mark = newsp;
2243     newsp = PL_stack_base + cx->blk_loop.resetsp;
2244
2245     SP = leave_common(newsp, SP, MARK, gimme, 0,
2246                                PL_op->op_private & OPpLVALUE);
2247     PUTBACK;
2248
2249     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2250     PL_curpm = newpm;   /* ... and pop $1 et al */
2251
2252     LEAVE_with_name("loop2");
2253     LEAVE_with_name("loop1");
2254
2255     return NORMAL;
2256 }
2257
2258 STATIC void
2259 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2260                        PERL_CONTEXT *cx, PMOP *newpm)
2261 {
2262     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2263     if (gimme == G_SCALAR) {
2264         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2265             SV *sv;
2266             const char *what = NULL;
2267             if (MARK < SP) {
2268                 assert(MARK+1 == SP);
2269                 if ((SvPADTMP(TOPs) ||
2270                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2271                        == SVf_READONLY
2272                     ) &&
2273                     !SvSMAGICAL(TOPs)) {
2274                     what =
2275                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2276                         : "a readonly value" : "a temporary";
2277                 }
2278                 else goto copy_sv;
2279             }
2280             else {
2281                 /* sub:lvalue{} will take us here. */
2282                 what = "undef";
2283             }
2284             LEAVE;
2285             cxstack_ix--;
2286             POPSUB(cx,sv);
2287             PL_curpm = newpm;
2288             LEAVESUB(sv);
2289             Perl_croak(aTHX_
2290                       "Can't return %s from lvalue subroutine", what
2291             );
2292         }
2293         if (MARK < SP) {
2294               copy_sv:
2295                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2296                     if (!SvPADTMP(*SP)) {
2297                         *++newsp = SvREFCNT_inc(*SP);
2298                         FREETMPS;
2299                         sv_2mortal(*newsp);
2300                     }
2301                     else {
2302                         /* FREETMPS could clobber it */
2303                         SV *sv = SvREFCNT_inc(*SP);
2304                         FREETMPS;
2305                         *++newsp = sv_mortalcopy(sv);
2306                         SvREFCNT_dec(sv);
2307                     }
2308                 }
2309                 else
2310                     *++newsp =
2311                       SvPADTMP(*SP)
2312                        ? sv_mortalcopy(*SP)
2313                        : !SvTEMP(*SP)
2314                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2315                           : *SP;
2316         }
2317         else {
2318             EXTEND(newsp,1);
2319             *++newsp = &PL_sv_undef;
2320         }
2321         if (CxLVAL(cx) & OPpDEREF) {
2322             SvGETMAGIC(TOPs);
2323             if (!SvOK(TOPs)) {
2324                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2325             }
2326         }
2327     }
2328     else if (gimme == G_ARRAY) {
2329         assert (!(CxLVAL(cx) & OPpDEREF));
2330         if (ref || !CxLVAL(cx))
2331             while (++MARK <= SP)
2332                 *++newsp =
2333                        SvFLAGS(*MARK) & SVs_PADTMP
2334                            ? sv_mortalcopy(*MARK)
2335                      : SvTEMP(*MARK)
2336                            ? *MARK
2337                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2338         else while (++MARK <= SP) {
2339             if (*MARK != &PL_sv_undef
2340                     && (SvPADTMP(*MARK)
2341                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2342                              == SVf_READONLY
2343                        )
2344             ) {
2345                     SV *sv;
2346                     /* Might be flattened array after $#array =  */
2347                     PUTBACK;
2348                     LEAVE;
2349                     cxstack_ix--;
2350                     POPSUB(cx,sv);
2351                     PL_curpm = newpm;
2352                     LEAVESUB(sv);
2353                /* diag_listed_as: Can't return %s from lvalue subroutine */
2354                     Perl_croak(aTHX_
2355                         "Can't return a %s from lvalue subroutine",
2356                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2357             }
2358             else
2359                 *++newsp =
2360                     SvTEMP(*MARK)
2361                        ? *MARK
2362                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2363         }
2364     }
2365     PL_stack_sp = newsp;
2366 }
2367
2368 PP(pp_return)
2369 {
2370     dSP; dMARK;
2371     PERL_CONTEXT *cx;
2372     bool popsub2 = FALSE;
2373     bool clear_errsv = FALSE;
2374     bool lval = FALSE;
2375     I32 gimme;
2376     SV **newsp;
2377     PMOP *newpm;
2378     I32 optype = 0;
2379     SV *namesv;
2380     SV *sv;
2381     OP *retop = NULL;
2382
2383     const I32 cxix = dopoptosub(cxstack_ix);
2384
2385     if (cxix < 0) {
2386         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2387                                      * sort block, which is a CXt_NULL
2388                                      * not a CXt_SUB */
2389             dounwind(0);
2390             PL_stack_base[1] = *PL_stack_sp;
2391             PL_stack_sp = PL_stack_base + 1;
2392             return 0;
2393         }
2394         else
2395             DIE(aTHX_ "Can't return outside a subroutine");
2396     }
2397     if (cxix < cxstack_ix)
2398         dounwind(cxix);
2399
2400     if (CxMULTICALL(&cxstack[cxix])) {
2401         gimme = cxstack[cxix].blk_gimme;
2402         if (gimme == G_VOID)
2403             PL_stack_sp = PL_stack_base;
2404         else if (gimme == G_SCALAR) {
2405             PL_stack_base[1] = *PL_stack_sp;
2406             PL_stack_sp = PL_stack_base + 1;
2407         }
2408         return 0;
2409     }
2410
2411     POPBLOCK(cx,newpm);
2412     switch (CxTYPE(cx)) {
2413     case CXt_SUB:
2414         popsub2 = TRUE;
2415         lval = !!CvLVALUE(cx->blk_sub.cv);
2416         retop = cx->blk_sub.retop;
2417         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2418         break;
2419     case CXt_EVAL:
2420         if (!(PL_in_eval & EVAL_KEEPERR))
2421             clear_errsv = TRUE;
2422         POPEVAL(cx);
2423         namesv = cx->blk_eval.old_namesv;
2424         retop = cx->blk_eval.retop;
2425         if (CxTRYBLOCK(cx))
2426             break;
2427         if (optype == OP_REQUIRE &&
2428             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2429         {
2430             /* Unassume the success we assumed earlier. */
2431             (void)hv_delete(GvHVn(PL_incgv),
2432                             SvPVX_const(namesv),
2433                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2434                             G_DISCARD);
2435             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2436         }
2437         break;
2438     case CXt_FORMAT:
2439         retop = cx->blk_sub.retop;
2440         POPFORMAT(cx);
2441         break;
2442     default:
2443         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2444     }
2445
2446     TAINT_NOT;
2447     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2448     else {
2449       if (gimme == G_SCALAR) {
2450         if (MARK < SP) {
2451             if (popsub2) {
2452                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2453                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2454                          && !SvMAGICAL(TOPs)) {
2455                         *++newsp = SvREFCNT_inc(*SP);
2456                         FREETMPS;
2457                         sv_2mortal(*newsp);
2458                     }
2459                     else {
2460                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2461                         FREETMPS;
2462                         *++newsp = sv_mortalcopy(sv);
2463                         SvREFCNT_dec(sv);
2464                     }
2465                 }
2466                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2467                           && !SvMAGICAL(*SP)) {
2468                     *++newsp = *SP;
2469                 }
2470                 else
2471                     *++newsp = sv_mortalcopy(*SP);
2472             }
2473             else
2474                 *++newsp = sv_mortalcopy(*SP);
2475         }
2476         else
2477             *++newsp = &PL_sv_undef;
2478       }
2479       else if (gimme == G_ARRAY) {
2480         while (++MARK <= SP) {
2481             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2482                                && !SvGMAGICAL(*MARK)
2483                         ? *MARK : sv_mortalcopy(*MARK);
2484             TAINT_NOT;          /* Each item is independent */
2485         }
2486       }
2487       PL_stack_sp = newsp;
2488     }
2489
2490     LEAVE;
2491     /* Stack values are safe: */
2492     if (popsub2) {
2493         cxstack_ix--;
2494         POPSUB(cx,sv);  /* release CV and @_ ... */
2495     }
2496     else
2497         sv = NULL;
2498     PL_curpm = newpm;   /* ... and pop $1 et al */
2499
2500     LEAVESUB(sv);
2501     if (clear_errsv) {
2502         CLEAR_ERRSV();
2503     }
2504     return retop;
2505 }
2506
2507 /* This duplicates parts of pp_leavesub, so that it can share code with
2508  * pp_return */
2509 PP(pp_leavesublv)
2510 {
2511     dSP;
2512     SV **newsp;
2513     PMOP *newpm;
2514     I32 gimme;
2515     PERL_CONTEXT *cx;
2516     SV *sv;
2517
2518     if (CxMULTICALL(&cxstack[cxstack_ix]))
2519         return 0;
2520
2521     POPBLOCK(cx,newpm);
2522     cxstack_ix++; /* temporarily protect top context */
2523
2524     TAINT_NOT;
2525
2526     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2527
2528     LEAVE;
2529     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2530     cxstack_ix--;
2531     PL_curpm = newpm;   /* ... and pop $1 et al */
2532
2533     LEAVESUB(sv);
2534     return cx->blk_sub.retop;
2535 }
2536
2537 static I32
2538 S_unwind_loop(pTHX_ const char * const opname)
2539 {
2540     I32 cxix;
2541     if (PL_op->op_flags & OPf_SPECIAL) {
2542         cxix = dopoptoloop(cxstack_ix);
2543         if (cxix < 0)
2544             /* diag_listed_as: Can't "last" outside a loop block */
2545             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2546     }
2547     else {
2548         dSP;
2549         STRLEN label_len;
2550         const char * const label =
2551             PL_op->op_flags & OPf_STACKED
2552                 ? SvPV(TOPs,label_len)
2553                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2554         const U32 label_flags =
2555             PL_op->op_flags & OPf_STACKED
2556                 ? SvUTF8(POPs)
2557                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2558         PUTBACK;
2559         cxix = dopoptolabel(label, label_len, label_flags);
2560         if (cxix < 0)
2561             /* diag_listed_as: Label not found for "last %s" */
2562             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2563                                        opname,
2564                                        SVfARG(PL_op->op_flags & OPf_STACKED
2565                                               && !SvGMAGICAL(TOPp1s)
2566                                               ? TOPp1s
2567                                               : newSVpvn_flags(label,
2568                                                     label_len,
2569                                                     label_flags | SVs_TEMP)));
2570     }
2571     if (cxix < cxstack_ix)
2572         dounwind(cxix);
2573     return cxix;
2574 }
2575
2576 PP(pp_last)
2577 {
2578     PERL_CONTEXT *cx;
2579     I32 pop2 = 0;
2580     I32 gimme;
2581     I32 optype;
2582     OP *nextop = NULL;
2583     SV **newsp;
2584     PMOP *newpm;
2585     SV *sv = NULL;
2586
2587     S_unwind_loop(aTHX_ "last");
2588
2589     POPBLOCK(cx,newpm);
2590     cxstack_ix++; /* temporarily protect top context */
2591     switch (CxTYPE(cx)) {
2592     case CXt_LOOP_LAZYIV:
2593     case CXt_LOOP_LAZYSV:
2594     case CXt_LOOP_FOR:
2595     case CXt_LOOP_PLAIN:
2596         pop2 = CxTYPE(cx);
2597         newsp = PL_stack_base + cx->blk_loop.resetsp;
2598         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2599         break;
2600     case CXt_SUB:
2601         pop2 = CXt_SUB;
2602         nextop = cx->blk_sub.retop;
2603         break;
2604     case CXt_EVAL:
2605         POPEVAL(cx);
2606         nextop = cx->blk_eval.retop;
2607         break;
2608     case CXt_FORMAT:
2609         POPFORMAT(cx);
2610         nextop = cx->blk_sub.retop;
2611         break;
2612     default:
2613         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2614     }
2615
2616     TAINT_NOT;
2617     PL_stack_sp = newsp;
2618
2619     LEAVE;
2620     cxstack_ix--;
2621     /* Stack values are safe: */
2622     switch (pop2) {
2623     case CXt_LOOP_LAZYIV:
2624     case CXt_LOOP_PLAIN:
2625     case CXt_LOOP_LAZYSV:
2626     case CXt_LOOP_FOR:
2627         POPLOOP(cx);    /* release loop vars ... */
2628         LEAVE;
2629         break;
2630     case CXt_SUB:
2631         POPSUB(cx,sv);  /* release CV and @_ ... */
2632         break;
2633     }
2634     PL_curpm = newpm;   /* ... and pop $1 et al */
2635
2636     LEAVESUB(sv);
2637     PERL_UNUSED_VAR(optype);
2638     PERL_UNUSED_VAR(gimme);
2639     return nextop;
2640 }
2641
2642 PP(pp_next)
2643 {
2644     PERL_CONTEXT *cx;
2645     const I32 inner = PL_scopestack_ix;
2646
2647     S_unwind_loop(aTHX_ "next");
2648
2649     /* clear off anything above the scope we're re-entering, but
2650      * save the rest until after a possible continue block */
2651     TOPBLOCK(cx);
2652     if (PL_scopestack_ix < inner)
2653         leave_scope(PL_scopestack[PL_scopestack_ix]);
2654     PL_curcop = cx->blk_oldcop;
2655     PERL_ASYNC_CHECK();
2656     return (cx)->blk_loop.my_op->op_nextop;
2657 }
2658
2659 PP(pp_redo)
2660 {
2661     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2662     PERL_CONTEXT *cx;
2663     I32 oldsave;
2664     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2665
2666     if (redo_op->op_type == OP_ENTER) {
2667         /* pop one less context to avoid $x being freed in while (my $x..) */
2668         cxstack_ix++;
2669         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2670         redo_op = redo_op->op_next;
2671     }
2672
2673     TOPBLOCK(cx);
2674     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2675     LEAVE_SCOPE(oldsave);
2676     FREETMPS;
2677     PL_curcop = cx->blk_oldcop;
2678     PERL_ASYNC_CHECK();
2679     return redo_op;
2680 }
2681
2682 STATIC OP *
2683 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2684 {
2685     OP **ops = opstack;
2686     static const char* const too_deep = "Target of goto is too deeply nested";
2687
2688     PERL_ARGS_ASSERT_DOFINDLABEL;
2689
2690     if (ops >= oplimit)
2691         Perl_croak(aTHX_ "%s", too_deep);
2692     if (o->op_type == OP_LEAVE ||
2693         o->op_type == OP_SCOPE ||
2694         o->op_type == OP_LEAVELOOP ||
2695         o->op_type == OP_LEAVESUB ||
2696         o->op_type == OP_LEAVETRY)
2697     {
2698         *ops++ = cUNOPo->op_first;
2699         if (ops >= oplimit)
2700             Perl_croak(aTHX_ "%s", too_deep);
2701     }
2702     *ops = 0;
2703     if (o->op_flags & OPf_KIDS) {
2704         OP *kid;
2705         /* First try all the kids at this level, since that's likeliest. */
2706         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2707             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2708                 STRLEN kid_label_len;
2709                 U32 kid_label_flags;
2710                 const char *kid_label = CopLABEL_len_flags(kCOP,
2711                                                     &kid_label_len, &kid_label_flags);
2712                 if (kid_label && (
2713                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2714                         (flags & SVf_UTF8)
2715                             ? (bytes_cmp_utf8(
2716                                         (const U8*)kid_label, kid_label_len,
2717                                         (const U8*)label, len) == 0)
2718                             : (bytes_cmp_utf8(
2719                                         (const U8*)label, len,
2720                                         (const U8*)kid_label, kid_label_len) == 0)
2721                     : ( len == kid_label_len && ((kid_label == label)
2722                                     || memEQ(kid_label, label, len)))))
2723                     return kid;
2724             }
2725         }
2726         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2727             if (kid == PL_lastgotoprobe)
2728                 continue;
2729             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2730                 if (ops == opstack)
2731                     *ops++ = kid;
2732                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2733                          ops[-1]->op_type == OP_DBSTATE)
2734                     ops[-1] = kid;
2735                 else
2736                     *ops++ = kid;
2737             }
2738             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2739                 return o;
2740         }
2741     }
2742     *ops = 0;
2743     return 0;
2744 }
2745
2746
2747 /* also used for: pp_dump() */
2748
2749 PP(pp_goto)
2750 {
2751     dVAR; dSP;
2752     OP *retop = NULL;
2753     I32 ix;
2754     PERL_CONTEXT *cx;
2755 #define GOTO_DEPTH 64
2756     OP *enterops[GOTO_DEPTH];
2757     const char *label = NULL;
2758     STRLEN label_len = 0;
2759     U32 label_flags = 0;
2760     const bool do_dump = (PL_op->op_type == OP_DUMP);
2761     static const char* const must_have_label = "goto must have label";
2762
2763     if (PL_op->op_flags & OPf_STACKED) {
2764         /* goto EXPR  or  goto &foo */
2765
2766         SV * const sv = POPs;
2767         SvGETMAGIC(sv);
2768
2769         /* This egregious kludge implements goto &subroutine */
2770         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2771             I32 cxix;
2772             PERL_CONTEXT *cx;
2773             CV *cv = MUTABLE_CV(SvRV(sv));
2774             AV *arg = GvAV(PL_defgv);
2775             I32 oldsave;
2776
2777         retry:
2778             if (!CvROOT(cv) && !CvXSUB(cv)) {
2779                 const GV * const gv = CvGV(cv);
2780                 if (gv) {
2781                     GV *autogv;
2782                     SV *tmpstr;
2783                     /* autoloaded stub? */
2784                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2785                         goto retry;
2786                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2787                                           GvNAMELEN(gv),
2788                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2789                     if (autogv && (cv = GvCV(autogv)))
2790                         goto retry;
2791                     tmpstr = sv_newmortal();
2792                     gv_efullname3(tmpstr, gv, NULL);
2793                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2794                 }
2795                 DIE(aTHX_ "Goto undefined subroutine");
2796             }
2797
2798             /* First do some returnish stuff. */
2799             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2800             FREETMPS;
2801             cxix = dopoptosub(cxstack_ix);
2802             if (cxix < cxstack_ix) {
2803                 if (cxix < 0) {
2804                     SvREFCNT_dec(cv);
2805                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2806                 }
2807                 dounwind(cxix);
2808             }
2809             TOPBLOCK(cx);
2810             SPAGAIN;
2811             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2812             if (CxTYPE(cx) == CXt_EVAL) {
2813                 SvREFCNT_dec(cv);
2814                 if (CxREALEVAL(cx))
2815                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2816                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2817                 else
2818                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2819                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2820             }
2821             else if (CxMULTICALL(cx))
2822             {
2823                 SvREFCNT_dec(cv);
2824                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2825             }
2826             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2827                 AV* av = cx->blk_sub.argarray;
2828
2829                 /* abandon the original @_ if it got reified or if it is
2830                    the same as the current @_ */
2831                 if (AvREAL(av) || av == arg) {
2832                     SvREFCNT_dec(av);
2833                     av = newAV();
2834                     AvREIFY_only(av);
2835                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2836                 }
2837                 else CLEAR_ARGARRAY(av);
2838             }
2839             /* We donate this refcount later to the callee’s pad. */
2840             SvREFCNT_inc_simple_void(arg);
2841             if (CxTYPE(cx) == CXt_SUB &&
2842                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2843                 SvREFCNT_dec(cx->blk_sub.cv);
2844             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2845             LEAVE_SCOPE(oldsave);
2846
2847             /* A destructor called during LEAVE_SCOPE could have undefined
2848              * our precious cv.  See bug #99850. */
2849             if (!CvROOT(cv) && !CvXSUB(cv)) {
2850                 const GV * const gv = CvGV(cv);
2851                 SvREFCNT_dec(arg);
2852                 if (gv) {
2853                     SV * const tmpstr = sv_newmortal();
2854                     gv_efullname3(tmpstr, gv, NULL);
2855                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2856                                SVfARG(tmpstr));
2857                 }
2858                 DIE(aTHX_ "Goto undefined subroutine");
2859             }
2860
2861             /* Now do some callish stuff. */
2862             SAVETMPS;
2863             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2864             if (CvISXSUB(cv)) {
2865                 OP* const retop = cx->blk_sub.retop;
2866                 SV **newsp;
2867                 I32 gimme;
2868                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2869                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2870                 SV** mark;
2871
2872                 PERL_UNUSED_VAR(newsp);
2873                 PERL_UNUSED_VAR(gimme);
2874
2875                 /* put GvAV(defgv) back onto stack */
2876                 if (items) {
2877                     EXTEND(SP, items+1); /* @_ could have been extended. */
2878                 }
2879                 mark = SP;
2880                 if (items) {
2881                     SSize_t index;
2882                     bool r = cBOOL(AvREAL(arg));
2883                     for (index=0; index<items; index++)
2884                     {
2885                         SV *sv;
2886                         if (m) {
2887                             SV ** const svp = av_fetch(arg, index, 0);
2888                             sv = svp ? *svp : NULL;
2889                         }
2890                         else sv = AvARRAY(arg)[index];
2891                         SP[index+1] = sv
2892                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2893                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2894                     }
2895                 }
2896                 SP += items;
2897                 SvREFCNT_dec(arg);
2898                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2899                     /* Restore old @_ */
2900                     arg = GvAV(PL_defgv);
2901                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2902                     SvREFCNT_dec(arg);
2903                 }
2904
2905                 /* XS subs don't have a CxSUB, so pop it */
2906                 POPBLOCK(cx, PL_curpm);
2907                 /* Push a mark for the start of arglist */
2908                 PUSHMARK(mark);
2909                 PUTBACK;
2910                 (void)(*CvXSUB(cv))(aTHX_ cv);
2911                 LEAVE;
2912                 PERL_ASYNC_CHECK();
2913                 return retop;
2914             }
2915             else {
2916                 PADLIST * const padlist = CvPADLIST(cv);
2917                 cx->blk_sub.cv = cv;
2918                 cx->blk_sub.olddepth = CvDEPTH(cv);
2919
2920                 CvDEPTH(cv)++;
2921                 if (CvDEPTH(cv) < 2)
2922                     SvREFCNT_inc_simple_void_NN(cv);
2923                 else {
2924                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2925                         sub_crush_depth(cv);
2926                     pad_push(padlist, CvDEPTH(cv));
2927                 }
2928                 PL_curcop = cx->blk_oldcop;
2929                 SAVECOMPPAD();
2930                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2931                 if (CxHASARGS(cx))
2932                 {
2933                     CX_CURPAD_SAVE(cx->blk_sub);
2934
2935                     /* cx->blk_sub.argarray has no reference count, so we
2936                        need something to hang on to our argument array so
2937                        that cx->blk_sub.argarray does not end up pointing
2938                        to freed memory as the result of undef *_.  So put
2939                        it in the callee’s pad, donating our refer-
2940                        ence count. */
2941                     if (arg) {
2942                         SvREFCNT_dec(PAD_SVl(0));
2943                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2944                     }
2945
2946                     /* GvAV(PL_defgv) might have been modified on scope
2947                        exit, so restore it. */
2948                     if (arg != GvAV(PL_defgv)) {
2949                         AV * const av = GvAV(PL_defgv);
2950                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2951                         SvREFCNT_dec(av);
2952                     }
2953                 }
2954                 else SvREFCNT_dec(arg);
2955                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2956                     Perl_get_db_sub(aTHX_ NULL, cv);
2957                     if (PERLDB_GOTO) {
2958                         CV * const gotocv = get_cvs("DB::goto", 0);
2959                         if (gotocv) {
2960                             PUSHMARK( PL_stack_sp );
2961                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2962                             PL_stack_sp--;
2963                         }
2964                     }
2965                 }
2966                 PERL_ASYNC_CHECK();
2967                 RETURNOP(CvSTART(cv));
2968             }
2969         }
2970         else {
2971             /* goto EXPR */
2972             label       = SvPV_nomg_const(sv, label_len);
2973             label_flags = SvUTF8(sv);
2974         }
2975     }
2976     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2977         /* goto LABEL  or  dump LABEL */
2978         label       = cPVOP->op_pv;
2979         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2980         label_len   = strlen(label);
2981     }
2982     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2983
2984     PERL_ASYNC_CHECK();
2985
2986     if (label_len) {
2987         OP *gotoprobe = NULL;
2988         bool leaving_eval = FALSE;
2989         bool in_block = FALSE;
2990         PERL_CONTEXT *last_eval_cx = NULL;
2991
2992         /* find label */
2993
2994         PL_lastgotoprobe = NULL;
2995         *enterops = 0;
2996         for (ix = cxstack_ix; ix >= 0; ix--) {
2997             cx = &cxstack[ix];
2998             switch (CxTYPE(cx)) {
2999             case CXt_EVAL:
3000                 leaving_eval = TRUE;
3001                 if (!CxTRYBLOCK(cx)) {
3002                     gotoprobe = (last_eval_cx ?
3003                                 last_eval_cx->blk_eval.old_eval_root :
3004                                 PL_eval_root);
3005                     last_eval_cx = cx;
3006                     break;
3007                 }
3008                 /* else fall through */
3009             case CXt_LOOP_LAZYIV:
3010             case CXt_LOOP_LAZYSV:
3011             case CXt_LOOP_FOR:
3012             case CXt_LOOP_PLAIN:
3013             case CXt_GIVEN:
3014             case CXt_WHEN:
3015                 gotoprobe = OP_SIBLING(cx->blk_oldcop);
3016                 break;
3017             case CXt_SUBST:
3018                 continue;
3019             case CXt_BLOCK:
3020                 if (ix) {
3021                     gotoprobe = OP_SIBLING(cx->blk_oldcop);
3022                     in_block = TRUE;
3023                 } else
3024                     gotoprobe = PL_main_root;
3025                 break;
3026             case CXt_SUB:
3027                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3028                     gotoprobe = CvROOT(cx->blk_sub.cv);
3029                     break;
3030                 }
3031                 /* FALLTHROUGH */
3032             case CXt_FORMAT:
3033             case CXt_NULL:
3034                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3035             default:
3036                 if (ix)
3037                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3038                         CxTYPE(cx), (long) ix);
3039                 gotoprobe = PL_main_root;
3040                 break;
3041             }
3042             if (gotoprobe) {
3043                 OP *sibl1, *sibl2;
3044
3045                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3046                                     enterops, enterops + GOTO_DEPTH);
3047                 if (retop)
3048                     break;
3049                 if ( (sibl1 = OP_SIBLING(gotoprobe)) &&
3050                      sibl1->op_type == OP_UNSTACK &&
3051                      (sibl2 = OP_SIBLING(sibl1)))
3052                 {
3053                     retop = dofindlabel(sibl2,
3054                                         label, label_len, label_flags, enterops,
3055                                         enterops + GOTO_DEPTH);
3056                     if (retop)
3057                         break;
3058                 }
3059             }
3060             PL_lastgotoprobe = gotoprobe;
3061         }
3062         if (!retop)
3063             DIE(aTHX_ "Can't find label %"UTF8f,
3064                        UTF8fARG(label_flags, label_len, label));
3065
3066         /* if we're leaving an eval, check before we pop any frames
3067            that we're not going to punt, otherwise the error
3068            won't be caught */
3069
3070         if (leaving_eval && *enterops && enterops[1]) {
3071             I32 i;
3072             for (i = 1; enterops[i]; i++)
3073                 if (enterops[i]->op_type == OP_ENTERITER)
3074                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3075         }
3076
3077         if (*enterops && enterops[1]) {
3078             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3079             if (enterops[i])
3080                 deprecate("\"goto\" to jump into a construct");
3081         }
3082
3083         /* pop unwanted frames */
3084
3085         if (ix < cxstack_ix) {
3086             I32 oldsave;
3087
3088             if (ix < 0)
3089                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3090             dounwind(ix);
3091             TOPBLOCK(cx);
3092             oldsave = PL_scopestack[PL_scopestack_ix];
3093             LEAVE_SCOPE(oldsave);
3094         }
3095
3096         /* push wanted frames */
3097
3098         if (*enterops && enterops[1]) {
3099             OP * const oldop = PL_op;
3100             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3101             for (; enterops[ix]; ix++) {
3102                 PL_op = enterops[ix];
3103                 /* Eventually we may want to stack the needed arguments
3104                  * for each op.  For now, we punt on the hard ones. */
3105                 if (PL_op->op_type == OP_ENTERITER)
3106                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3107                 PL_op->op_ppaddr(aTHX);
3108             }
3109             PL_op = oldop;
3110         }
3111     }
3112
3113     if (do_dump) {
3114 #ifdef VMS
3115         if (!retop) retop = PL_main_start;
3116 #endif
3117         PL_restartop = retop;
3118         PL_do_undump = TRUE;
3119
3120         my_unexec();
3121
3122         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3123         PL_do_undump = FALSE;
3124     }
3125
3126     PERL_ASYNC_CHECK();
3127     RETURNOP(retop);
3128 }
3129
3130 PP(pp_exit)
3131 {
3132     dSP;
3133     I32 anum;
3134
3135     if (MAXARG < 1)
3136         anum = 0;
3137     else if (!TOPs) {
3138         anum = 0; (void)POPs;
3139     }
3140     else {
3141         anum = SvIVx(POPs);
3142 #ifdef VMS
3143         if (anum == 1
3144          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3145             anum = 0;
3146         VMSISH_HUSHED  =
3147             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3148 #endif
3149     }
3150     PL_exit_flags |= PERL_EXIT_EXPECTED;
3151     my_exit(anum);
3152     PUSHs(&PL_sv_undef);
3153     RETURN;
3154 }
3155
3156 /* Eval. */
3157
3158 STATIC void
3159 S_save_lines(pTHX_ AV *array, SV *sv)
3160 {
3161     const char *s = SvPVX_const(sv);
3162     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3163     I32 line = 1;
3164
3165     PERL_ARGS_ASSERT_SAVE_LINES;
3166
3167     while (s && s < send) {
3168         const char *t;
3169         SV * const tmpstr = newSV_type(SVt_PVMG);
3170
3171         t = (const char *)memchr(s, '\n', send - s);
3172         if (t)
3173             t++;
3174         else
3175             t = send;
3176
3177         sv_setpvn(tmpstr, s, t - s);
3178         av_store(array, line++, tmpstr);
3179         s = t;
3180     }
3181 }
3182
3183 /*
3184 =for apidoc docatch
3185
3186 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3187
3188 0 is used as continue inside eval,
3189
3190 3 is used for a die caught by an inner eval - continue inner loop
3191
3192 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3193 establish a local jmpenv to handle exception traps.
3194
3195 =cut
3196 */
3197 STATIC OP *
3198 S_docatch(pTHX_ OP *o)
3199 {
3200     int ret;
3201     OP * const oldop = PL_op;
3202     dJMPENV;
3203
3204 #ifdef DEBUGGING
3205     assert(CATCH_GET == TRUE);
3206 #endif
3207     PL_op = o;
3208
3209     JMPENV_PUSH(ret);
3210     switch (ret) {
3211     case 0:
3212         assert(cxstack_ix >= 0);
3213         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3214         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3215  redo_body:
3216         CALLRUNOPS(aTHX);
3217         break;
3218     case 3:
3219         /* die caught by an inner eval - continue inner loop */
3220         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3221             PL_restartjmpenv = NULL;
3222             PL_op = PL_restartop;
3223             PL_restartop = 0;
3224             goto redo_body;
3225         }
3226         /* FALLTHROUGH */
3227     default:
3228         JMPENV_POP;
3229         PL_op = oldop;
3230         JMPENV_JUMP(ret);
3231         assert(0); /* NOTREACHED */
3232     }
3233     JMPENV_POP;
3234     PL_op = oldop;
3235     return NULL;
3236 }
3237
3238
3239 /*
3240 =for apidoc find_runcv
3241
3242 Locate the CV corresponding to the currently executing sub or eval.
3243 If db_seqp is non_null, skip CVs that are in the DB package and populate
3244 *db_seqp with the cop sequence number at the point that the DB:: code was
3245 entered.  (This allows debuggers to eval in the scope of the breakpoint
3246 rather than in the scope of the debugger itself.)
3247
3248 =cut
3249 */
3250
3251 CV*
3252 Perl_find_runcv(pTHX_ U32 *db_seqp)
3253 {
3254     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3255 }
3256
3257 /* If this becomes part of the API, it might need a better name. */
3258 CV *
3259 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3260 {
3261     PERL_SI      *si;
3262     int          level = 0;
3263
3264     if (db_seqp)
3265         *db_seqp =
3266             PL_curcop == &PL_compiling
3267                 ? PL_cop_seqmax
3268                 : PL_curcop->cop_seq;
3269
3270     for (si = PL_curstackinfo; si; si = si->si_prev) {
3271         I32 ix;
3272         for (ix = si->si_cxix; ix >= 0; ix--) {
3273             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3274             CV *cv = NULL;
3275             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3276                 cv = cx->blk_sub.cv;
3277                 /* skip DB:: code */
3278                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3279                     *db_seqp = cx->blk_oldcop->cop_seq;
3280                     continue;
3281                 }
3282                 if (cx->cx_type & CXp_SUB_RE)
3283                     continue;
3284             }
3285             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3286                 cv = cx->blk_eval.cv;
3287             if (cv) {
3288                 switch (cond) {
3289                 case FIND_RUNCV_padid_eq:
3290                     if (!CvPADLIST(cv)
3291                      || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3292                         continue;
3293                     return cv;
3294                 case FIND_RUNCV_level_eq:
3295                     if (level++ != arg) continue;
3296                     /* GERONIMO! */
3297                 default:
3298                     return cv;
3299                 }
3300             }
3301         }
3302     }
3303     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3304 }
3305
3306
3307 /* Run yyparse() in a setjmp wrapper. Returns:
3308  *   0: yyparse() successful
3309  *   1: yyparse() failed
3310  *   3: yyparse() died
3311  */
3312 STATIC int
3313 S_try_yyparse(pTHX_ int gramtype)
3314 {
3315     int ret;
3316     dJMPENV;
3317
3318     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3319     JMPENV_PUSH(ret);
3320     switch (ret) {
3321     case 0:
3322         ret = yyparse(gramtype) ? 1 : 0;
3323         break;
3324     case 3:
3325         break;
3326     default:
3327         JMPENV_POP;
3328         JMPENV_JUMP(ret);
3329         assert(0); /* NOTREACHED */
3330     }
3331     JMPENV_POP;
3332     return ret;
3333 }
3334
3335
3336 /* Compile a require/do or an eval ''.
3337  *
3338  * outside is the lexically enclosing CV (if any) that invoked us.
3339  * seq     is the current COP scope value.
3340  * hh      is the saved hints hash, if any.
3341  *
3342  * Returns a bool indicating whether the compile was successful; if so,
3343  * PL_eval_start contains the first op of the compiled code; otherwise,
3344  * pushes undef.
3345  *
3346  * This function is called from two places: pp_require and pp_entereval.
3347  * These can be distinguished by whether PL_op is entereval.
3348  */
3349
3350 STATIC bool
3351 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3352 {
3353     dSP;
3354     OP * const saveop = PL_op;
3355     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3356     COP * const oldcurcop = PL_curcop;
3357     bool in_require = (saveop->op_type == OP_REQUIRE);
3358     int yystatus;
3359     CV *evalcv;
3360
3361     PL_in_eval = (in_require
3362                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3363                   : (EVAL_INEVAL |
3364                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3365                             ? EVAL_RE_REPARSING : 0)));
3366
3367     PUSHMARK(SP);
3368
3369     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3370     CvEVAL_on(evalcv);
3371     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3372     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3373     cxstack[cxstack_ix].blk_gimme = gimme;
3374
3375     CvOUTSIDE_SEQ(evalcv) = seq;
3376     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3377
3378     /* set up a scratch pad */
3379
3380     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3381     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3382
3383
3384     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3385
3386     /* make sure we compile in the right package */
3387
3388     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3389         SAVEGENERICSV(PL_curstash);
3390         PL_curstash = (HV *)CopSTASH(PL_curcop);
3391         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3392         else SvREFCNT_inc_simple_void(PL_curstash);
3393     }
3394     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3395     SAVESPTR(PL_beginav);
3396     PL_beginav = newAV();
3397     SAVEFREESV(PL_beginav);
3398     SAVESPTR(PL_unitcheckav);
3399     PL_unitcheckav = newAV();
3400     SAVEFREESV(PL_unitcheckav);
3401
3402
3403     ENTER_with_name("evalcomp");
3404     SAVESPTR(PL_compcv);
3405     PL_compcv = evalcv;
3406
3407     /* try to compile it */
3408
3409     PL_eval_root = NULL;
3410     PL_curcop = &PL_compiling;
3411     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3412         PL_in_eval |= EVAL_KEEPERR;
3413     else
3414         CLEAR_ERRSV();
3415
3416     SAVEHINTS();
3417     if (clear_hints) {
3418         PL_hints = 0;
3419         hv_clear(GvHV(PL_hintgv));
3420     }
3421     else {
3422         PL_hints = saveop->op_private & OPpEVAL_COPHH
3423                      ? oldcurcop->cop_hints : saveop->op_targ;
3424
3425         /* making 'use re eval' not be in scope when compiling the
3426          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3427          * infinite recursion when S_has_runtime_code() gives a false
3428          * positive: the second time round, HINT_RE_EVAL isn't set so we
3429          * don't bother calling S_has_runtime_code() */
3430         if (PL_in_eval & EVAL_RE_REPARSING)
3431             PL_hints &= ~HINT_RE_EVAL;
3432
3433         if (hh) {
3434             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3435             SvREFCNT_dec(GvHV(PL_hintgv));
3436             GvHV(PL_hintgv) = hh;
3437         }
3438     }
3439     SAVECOMPILEWARNINGS();
3440     if (clear_hints) {
3441         if (PL_dowarn & G_WARN_ALL_ON)
3442             PL_compiling.cop_warnings = pWARN_ALL ;
3443         else if (PL_dowarn & G_WARN_ALL_OFF)
3444             PL_compiling.cop_warnings = pWARN_NONE ;
3445         else
3446             PL_compiling.cop_warnings = pWARN_STD ;
3447     }
3448     else {
3449         PL_compiling.cop_warnings =
3450             DUP_WARNINGS(oldcurcop->cop_warnings);
3451         cophh_free(CopHINTHASH_get(&PL_compiling));
3452         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3453             /* The label, if present, is the first entry on the chain. So rather
3454                than writing a blank label in front of it (which involves an
3455                allocation), just use the next entry in the chain.  */
3456             PL_compiling.cop_hints_hash
3457                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3458             /* Check the assumption that this removed the label.  */
3459             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3460         }
3461         else
3462             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3463     }
3464
3465     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3466
3467     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3468      * so honour CATCH_GET and trap it here if necessary */
3469
3470     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3471
3472     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3473         SV **newsp;                     /* Used by POPBLOCK. */
3474         PERL_CONTEXT *cx;
3475         I32 optype;                     /* Used by POPEVAL. */
3476         SV *namesv;
3477         SV *errsv = NULL;
3478
3479         cx = NULL;
3480         namesv = NULL;
3481         PERL_UNUSED_VAR(newsp);
3482         PERL_UNUSED_VAR(optype);
3483
3484         /* note that if yystatus == 3, then the EVAL CX block has already
3485          * been popped, and various vars restored */
3486         PL_op = saveop;
3487         if (yystatus != 3) {
3488             if (PL_eval_root) {
3489                 op_free(PL_eval_root);
3490                 PL_eval_root = NULL;
3491             }
3492             SP = PL_stack_base + POPMARK;       /* pop original mark */
3493             POPBLOCK(cx,PL_curpm);
3494             POPEVAL(cx);
3495             namesv = cx->blk_eval.old_namesv;
3496             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3497             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3498         }
3499
3500         errsv = ERRSV;
3501         if (in_require) {
3502             if (!cx) {
3503                 /* If cx is still NULL, it means that we didn't go in the
3504                  * POPEVAL branch. */
3505                 cx = &cxstack[cxstack_ix];
3506                 assert(CxTYPE(cx) == CXt_EVAL);
3507                 namesv = cx->blk_eval.old_namesv;
3508             }
3509             (void)hv_store(GvHVn(PL_incgv),
3510                            SvPVX_const(namesv),
3511                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3512                            &PL_sv_undef, 0);
3513             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3514                        SVfARG(errsv
3515                                 ? errsv
3516                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3517         }
3518         else {
3519             if (!*(SvPV_nolen_const(errsv))) {
3520                 sv_setpvs(errsv, "Compilation error");
3521             }
3522         }
3523         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3524         PUTBACK;
3525         return FALSE;
3526     }
3527     else
3528         LEAVE_with_name("evalcomp");
3529
3530     CopLINE_set(&PL_compiling, 0);
3531     SAVEFREEOP(PL_eval_root);
3532     cv_forget_slab(evalcv);
3533
3534     DEBUG_x(dump_eval());
3535
3536     /* Register with debugger: */
3537     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3538         CV * const cv = get_cvs("DB::postponed", 0);
3539         if (cv) {
3540             dSP;
3541             PUSHMARK(SP);
3542             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3543             PUTBACK;
3544             call_sv(MUTABLE_SV(cv), G_DISCARD);
3545         }
3546     }
3547
3548     if (PL_unitcheckav) {
3549         OP *es = PL_eval_start;
3550         call_list(PL_scopestack_ix, PL_unitcheckav);
3551         PL_eval_start = es;
3552     }
3553
3554     /* compiled okay, so do it */
3555
3556     CvDEPTH(evalcv) = 1;
3557     SP = PL_stack_base + POPMARK;               /* pop original mark */
3558     PL_op = saveop;                     /* The caller may need it. */
3559     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3560
3561     PUTBACK;
3562     return TRUE;
3563 }
3564
3565 STATIC PerlIO *
3566 S_check_type_and_open(pTHX_ SV *name)
3567 {
3568     Stat_t st;
3569     STRLEN len;
3570     const char *p = SvPV_const(name, len);
3571     int st_rc;
3572
3573     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3574
3575     /* checking here captures a reasonable error message when
3576      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3577      * user gets a confusing message about looking for the .pmc file
3578      * rather than for the .pm file.
3579      * This check prevents a \0 in @INC causing problems.
3580      */
3581     if (!IS_SAFE_PATHNAME(p, len, "require"))
3582         return NULL;
3583
3584     /* we use the value of errno later to see how stat() or open() failed.
3585      * We don't want it set if the stat succeeded but we still failed,
3586      * such as if the name exists, but is a directory */
3587     errno = 0;
3588
3589     st_rc = PerlLIO_stat(p, &st);
3590
3591     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3592         return NULL;
3593     }
3594
3595 #if !defined(PERLIO_IS_STDIO)
3596     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3597 #else
3598     return PerlIO_open(p, PERL_SCRIPT_MODE);
3599 #endif
3600 }
3601
3602 #ifndef PERL_DISABLE_PMC
3603 STATIC PerlIO *
3604 S_doopen_pm(pTHX_ SV *name)
3605 {
3606     STRLEN namelen;
3607     const char *p = SvPV_const(name, namelen);
3608
3609     PERL_ARGS_ASSERT_DOOPEN_PM;
3610
3611     /* check the name before trying for the .pmc name to avoid the
3612      * warning referring to the .pmc which the user probably doesn't
3613      * know or care about
3614      */
3615     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3616         return NULL;
3617
3618     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3619         SV *const pmcsv = sv_newmortal();
3620         Stat_t pmcstat;
3621
3622         SvSetSV_nosteal(pmcsv,name);
3623         sv_catpvs(pmcsv, "c");
3624
3625         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3626             return check_type_and_open(pmcsv);
3627     }
3628     return check_type_and_open(name);
3629 }
3630 #else
3631 #  define doopen_pm(name) check_type_and_open(name)
3632 #endif /* !PERL_DISABLE_PMC */
3633
3634 /* require doesn't search for absolute names, or when the name is
3635    explicity relative the current directory */
3636 PERL_STATIC_INLINE bool
3637 S_path_is_searchable(const char *name)
3638 {
3639     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3640
3641     if (PERL_FILE_IS_ABSOLUTE(name)
3642 #ifdef WIN32
3643         || (*name == '.' && ((name[1] == '/' ||
3644                              (name[1] == '.' && name[2] == '/'))
3645                          || (name[1] == '\\' ||
3646                              ( name[1] == '.' && name[2] == '\\')))
3647             )
3648 #else
3649         || (*name == '.' && (name[1] == '/' ||
3650                              (name[1] == '.' && name[2] == '/')))
3651 #endif
3652          )
3653     {
3654         return FALSE;
3655     }
3656     else
3657         return TRUE;
3658 }
3659
3660
3661 /* also used for: pp_dofile() */
3662
3663 PP(pp_require)
3664 {
3665     dSP;
3666     PERL_CONTEXT *cx;
3667     SV *sv;
3668     const char *name;
3669     STRLEN len;
3670     char * unixname;
3671     STRLEN unixlen;
3672 #ifdef VMS
3673     int vms_unixname = 0;
3674     char *unixdir;
3675 #endif
3676     const char *tryname = NULL;
3677     SV *namesv = NULL;
3678     const I32 gimme = GIMME_V;
3679     int filter_has_file = 0;
3680     PerlIO *tryrsfp = NULL;
3681     SV *filter_cache = NULL;
3682     SV *filter_state = NULL;
3683     SV *filter_sub = NULL;
3684     SV *hook_sv = NULL;
3685     SV *encoding;
3686     OP *op;
3687     int saved_errno;
3688     bool path_searchable;
3689
3690     sv = POPs;
3691     SvGETMAGIC(sv);
3692     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3693         sv = sv_2mortal(new_version(sv));
3694         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3695             upg_version(PL_patchlevel, TRUE);
3696         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3697             if ( vcmp(sv,PL_patchlevel) <= 0 )
3698                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3699                     SVfARG(sv_2mortal(vnormal(sv))),
3700                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3701                 );
3702         }
3703         else {
3704             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3705                 I32 first = 0;
3706                 AV *lav;
3707                 SV * const req = SvRV(sv);
3708                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3709
3710                 /* get the left hand term */
3711                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3712
3713                 first  = SvIV(*av_fetch(lav,0,0));
3714                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3715                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3716                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3717                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3718                    ) {
3719                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3720                         "%"SVf", stopped",
3721                         SVfARG(sv_2mortal(vnormal(req))),
3722                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3723                     );
3724                 }
3725                 else { /* probably 'use 5.10' or 'use 5.8' */
3726                     SV *hintsv;
3727                     I32 second = 0;
3728
3729                     if (av_tindex(lav)>=1)
3730                         second = SvIV(*av_fetch(lav,1,0));
3731
3732                     second /= second >= 600  ? 100 : 10;
3733                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3734                                            (int)first, (int)second);
3735                     upg_version(hintsv, TRUE);
3736
3737                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3738                         "--this is only %"SVf", stopped",
3739                         SVfARG(sv_2mortal(vnormal(req))),
3740                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3741                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3742                     );
3743                 }
3744             }
3745         }
3746
3747         RETPUSHYES;
3748     }
3749     if (!SvOK(sv))
3750         DIE(aTHX_ "Missing or undefined argument to require");
3751     name = SvPV_nomg_const(sv, len);
3752     if (!(name && len > 0 && *name))
3753         DIE(aTHX_ "Missing or undefined argument to require");
3754
3755     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3756         DIE(aTHX_ "Can't locate %s:   %s",
3757             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3758                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3759             Strerror(ENOENT));
3760     }
3761     TAINT_PROPER("require");
3762
3763     path_searchable = path_is_searchable(name);
3764
3765 #ifdef VMS
3766     /* The key in the %ENV hash is in the syntax of file passed as the argument
3767      * usually this is in UNIX format, but sometimes in VMS format, which
3768      * can result in a module being pulled in more than once.
3769      * To prevent this, the key must be stored in UNIX format if the VMS
3770      * name can be translated to UNIX.
3771      */
3772
3773     if ((unixname =
3774           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3775          != NULL) {
3776         unixlen = strlen(unixname);
3777         vms_unixname = 1;
3778     }
3779     else
3780 #endif
3781     {
3782         /* if not VMS or VMS name can not be translated to UNIX, pass it
3783          * through.
3784          */
3785         unixname = (char *) name;
3786         unixlen = len;
3787     }
3788     if (PL_op->op_type == OP_REQUIRE) {
3789         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3790                                           unixname, unixlen, 0);
3791         if ( svp ) {
3792             if (*svp != &PL_sv_undef)
3793                 RETPUSHYES;
3794             else
3795                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3796                             "Compilation failed in require", unixname);
3797         }
3798     }
3799
3800     LOADING_FILE_PROBE(unixname);
3801
3802     /* prepare to compile file */
3803
3804     if (!path_searchable) {
3805         /* At this point, name is SvPVX(sv)  */
3806         tryname = name;
3807         tryrsfp = doopen_pm(sv);
3808     }
3809     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3810         AV * const ar = GvAVn(PL_incgv);
3811         SSize_t i;
3812 #ifdef VMS
3813         if (vms_unixname)
3814 #endif
3815         {
3816             SV *nsv = sv;
3817             namesv = newSV_type(SVt_PV);
3818             for (i = 0; i <= AvFILL(ar); i++) {
3819                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3820
3821                 SvGETMAGIC(dirsv);
3822                 if (SvROK(dirsv)) {
3823                     int count;
3824                     SV **svp;
3825                     SV *loader = dirsv;
3826
3827                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3828                         && !SvOBJECT(SvRV(loader)))
3829                     {
3830                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3831                         SvGETMAGIC(loader);
3832                     }
3833
3834                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3835                                    PTR2UV(SvRV(dirsv)), name);
3836                     tryname = SvPVX_const(namesv);
3837                     tryrsfp = NULL;
3838
3839                     if (SvPADTMP(nsv)) {
3840                         nsv = sv_newmortal();
3841                         SvSetSV_nosteal(nsv,sv);
3842                     }
3843
3844                     ENTER_with_name("call_INC");
3845                     SAVETMPS;
3846                     EXTEND(SP, 2);
3847
3848                     PUSHMARK(SP);
3849                     PUSHs(dirsv);
3850                     PUSHs(nsv);
3851                     PUTBACK;
3852                     if (SvGMAGICAL(loader)) {
3853                         SV *l = sv_newmortal();
3854                         sv_setsv_nomg(l, loader);
3855                         loader = l;
3856                     }
3857                     if (sv_isobject(loader))
3858                         count = call_method("INC", G_ARRAY);
3859                     else
3860                         count = call_sv(loader, G_ARRAY);
3861                     SPAGAIN;
3862
3863                     if (count > 0) {
3864                         int i = 0;
3865                         SV *arg;
3866
3867                         SP -= count - 1;
3868                         arg = SP[i++];
3869
3870                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3871                             && !isGV_with_GP(SvRV(arg))) {
3872                             filter_cache = SvRV(arg);
3873
3874                             if (i < count) {
3875                                 arg = SP[i++];
3876                             }
3877                         }
3878
3879                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3880                             arg = SvRV(arg);
3881                         }
3882
3883                         if (isGV_with_GP(arg)) {
3884                             IO * const io = GvIO((const GV *)arg);
3885
3886                             ++filter_has_file;
3887
3888                             if (io) {
3889                                 tryrsfp = IoIFP(io);
3890                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3891                                     PerlIO_close(IoOFP(io));
3892                                 }
3893                                 IoIFP(io) = NULL;
3894                                 IoOFP(io) = NULL;
3895                             }
3896
3897                             if (i < count) {
3898                                 arg = SP[i++];
3899                             }
3900                         }
3901
3902                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3903                             filter_sub = arg;
3904                             SvREFCNT_inc_simple_void_NN(filter_sub);
3905
3906                             if (i < count) {
3907                                 filter_state = SP[i];
3908                                 SvREFCNT_inc_simple_void(filter_state);
3909                             }
3910                         }
3911
3912                         if (!tryrsfp && (filter_cache || filter_sub)) {
3913                             tryrsfp = PerlIO_open(BIT_BUCKET,
3914                                                   PERL_SCRIPT_MODE);
3915                         }
3916                         SP--;
3917                     }
3918
3919                     /* FREETMPS may free our filter_cache */
3920                     SvREFCNT_inc_simple_void(filter_cache);
3921
3922                     PUTBACK;
3923                     FREETMPS;
3924                     LEAVE_with_name("call_INC");
3925
3926                     /* Now re-mortalize it. */
3927                     sv_2mortal(filter_cache);
3928
3929                     /* Adjust file name if the hook has set an %INC entry.
3930                        This needs to happen after the FREETMPS above.  */
3931                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3932                     if (svp)
3933                         tryname = SvPV_nolen_const(*svp);
3934
3935                     if (tryrsfp) {
3936                         hook_sv = dirsv;
3937                         break;
3938                     }
3939
3940                     filter_has_file = 0;
3941                     filter_cache = NULL;
3942                     if (filter_state) {
3943                         SvREFCNT_dec_NN(filter_state);
3944                         filter_state = NULL;
3945                     }
3946                     if (filter_sub) {
3947                         SvREFCNT_dec_NN(filter_sub);
3948                         filter_sub = NULL;
3949                     }
3950                 }
3951                 else {
3952                   if (path_searchable) {
3953                     const char *dir;
3954                     STRLEN dirlen;
3955
3956                     if (SvOK(dirsv)) {
3957                         dir = SvPV_nomg_const(dirsv, dirlen);
3958                     } else {
3959                         dir = "";
3960                         dirlen = 0;
3961                     }
3962
3963                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3964                         continue;
3965 #ifdef VMS
3966                     if ((unixdir =
3967                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3968                          == NULL)
3969                         continue;
3970                     sv_setpv(namesv, unixdir);
3971                     sv_catpv(namesv, unixname);
3972 #else
3973 #  ifdef __SYMBIAN32__
3974                     if (PL_origfilename[0] &&
3975                         PL_origfilename[1] == ':' &&
3976                         !(dir[0] && dir[1] == ':'))
3977                         Perl_sv_setpvf(aTHX_ namesv,
3978                                        "%c:%s\\%s",
3979                                        PL_origfilename[0],
3980                                        dir, name);
3981                     else
3982                         Perl_sv_setpvf(aTHX_ namesv,
3983                                        "%s\\%s",
3984                                        dir, name);
3985 #  else
3986                     /* The equivalent of
3987                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3988                        but without the need to parse the format string, or
3989                        call strlen on either pointer, and with the correct
3990                        allocation up front.  */
3991                     {
3992                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3993
3994                         memcpy(tmp, dir, dirlen);
3995                         tmp +=dirlen;
3996
3997                         /* Avoid '<dir>//<file>' */
3998                         if (!dirlen || *(tmp-1) != '/') {
3999                             *tmp++ = '/';
4000                         } else {
4001                             /* So SvCUR_set reports the correct length below */
4002                             dirlen--;
4003                         }
4004
4005                         /* name came from an SV, so it will have a '\0' at the
4006                            end that we can copy as part of this memcpy().  */
4007                         memcpy(tmp, name, len + 1);
4008
4009                         SvCUR_set(namesv, dirlen + len + 1);
4010                         SvPOK_on(namesv);
4011                     }
4012 #  endif
4013 #endif
4014                     TAINT_PROPER("require");
4015                     tryname = SvPVX_const(namesv);
4016                     tryrsfp = doopen_pm(namesv);
4017                     if (tryrsfp) {
4018                         if (tryname[0] == '.' && tryname[1] == '/') {
4019                             ++tryname;
4020                             while (*++tryname == '/') {}
4021                         }
4022                         break;
4023                     }
4024                     else if (errno == EMFILE || errno == EACCES) {
4025                         /* no point in trying other paths if out of handles;
4026                          * on the other hand, if we couldn't open one of the
4027                          * files, then going on with the search could lead to
4028                          * unexpected results; see perl #113422
4029                          */
4030                         break;
4031                     }
4032                   }
4033                 }
4034             }
4035         }
4036     }
4037     saved_errno = errno; /* sv_2mortal can realloc things */
4038     sv_2mortal(namesv);
4039     if (!tryrsfp) {
4040         if (PL_op->op_type == OP_REQUIRE) {
4041             if(saved_errno == EMFILE || saved_errno == EACCES) {
4042                 /* diag_listed_as: Can't locate %s */
4043                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
4044             } else {
4045                 if (namesv) {                   /* did we lookup @INC? */
4046                     AV * const ar = GvAVn(PL_incgv);
4047                     SSize_t i;
4048                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4049                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4050                     for (i = 0; i <= AvFILL(ar); i++) {
4051                         sv_catpvs(inc, " ");
4052                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4053                     }
4054                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4055                         const char *c, *e = name + len - 3;
4056                         sv_catpv(msg, " (you may need to install the ");
4057                         for (c = name; c < e; c++) {
4058                             if (*c == '/') {
4059                                 sv_catpvs(msg, "::");
4060                             }
4061                             else {
4062                                 sv_catpvn(msg, c, 1);
4063                             }
4064                         }
4065                         sv_catpv(msg, " module)");
4066                     }
4067                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4068                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4069                     }
4070                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4071                         sv_catpv(msg, " (did you run h2ph?)");
4072                     }
4073
4074                     /* diag_listed_as: Can't locate %s */
4075                     DIE(aTHX_
4076                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4077                         name, msg, inc);
4078                 }
4079             }
4080             DIE(aTHX_ "Can't locate %s", name);
4081         }
4082
4083         CLEAR_ERRSV();
4084         RETPUSHUNDEF;
4085     }
4086     else
4087         SETERRNO(0, SS_NORMAL);
4088
4089     /* Assume success here to prevent recursive requirement. */
4090     /* name is never assigned to again, so len is still strlen(name)  */
4091     /* Check whether a hook in @INC has already filled %INC */
4092     if (!hook_sv) {
4093         (void)hv_store(GvHVn(PL_incgv),
4094                        unixname, unixlen, newSVpv(tryname,0),0);
4095     } else {
4096         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4097         if (!svp)
4098             (void)hv_store(GvHVn(PL_incgv),
4099                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4100     }
4101
4102     ENTER_with_name("eval");
4103     SAVETMPS;
4104     SAVECOPFILE_FREE(&PL_compiling);
4105     CopFILE_set(&PL_compiling, tryname);
4106     lex_start(NULL, tryrsfp, 0);
4107
4108     if (filter_sub || filter_cache) {
4109         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4110            than hanging another SV from it. In turn, filter_add() optionally
4111            takes the SV to use as the filter (or creates a new SV if passed
4112            NULL), so simply pass in whatever value filter_cache has.  */
4113         SV * const fc = filter_cache ? newSV(0) : NULL;
4114         SV *datasv;
4115         if (fc) sv_copypv(fc, filter_cache);
4116         datasv = filter_add(S_run_user_filter, fc);
4117         IoLINES(datasv) = filter_has_file;
4118         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4119         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4120     }
4121
4122     /* switch to eval mode */
4123     PUSHBLOCK(cx, CXt_EVAL, SP);
4124     PUSHEVAL(cx, name);
4125     cx->blk_eval.retop = PL_op->op_next;
4126
4127     SAVECOPLINE(&PL_compiling);
4128     CopLINE_set(&PL_compiling, 0);
4129
4130     PUTBACK;
4131
4132     /* Store and reset encoding. */
4133     encoding = PL_encoding;
4134     PL_encoding = NULL;
4135
4136     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4137         op = DOCATCH(PL_eval_start);
4138     else
4139         op = PL_op->op_next;
4140
4141     /* Restore encoding. */
4142     PL_encoding = encoding;
4143
4144     LOADED_FILE_PROBE(unixname);
4145
4146     return op;
4147 }
4148
4149 /* This is a op added to hold the hints hash for
4150    pp_entereval. The hash can be modified by the code
4151    being eval'ed, so we return a copy instead. */
4152
4153 PP(pp_hintseval)
4154 {
4155     dSP;
4156     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4157     RETURN;
4158 }
4159
4160
4161 PP(pp_entereval)
4162 {
4163     dSP;
4164     PERL_CONTEXT *cx;
4165     SV *sv;
4166     const I32 gimme = GIMME_V;
4167     const U32 was = PL_breakable_sub_gen;
4168     char tbuf[TYPE_DIGITS(long) + 12];
4169     bool saved_delete = FALSE;
4170     char *tmpbuf = tbuf;
4171     STRLEN len;
4172     CV* runcv;
4173     U32 seq, lex_flags = 0;
4174     HV *saved_hh = NULL;
4175     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4176
4177     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4178         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4179     }
4180     else if (PL_hints & HINT_LOCALIZE_HH || (
4181                 PL_op->op_private & OPpEVAL_COPHH
4182              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4183             )) {
4184         saved_hh = cop_hints_2hv(PL_curcop, 0);
4185         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4186     }
4187     sv = POPs;
4188     if (!SvPOK(sv)) {
4189         /* make sure we've got a plain PV (no overload etc) before testing
4190          * for taint. Making a copy here is probably overkill, but better
4191          * safe than sorry */
4192         STRLEN len;
4193         const char * const p = SvPV_const(sv, len);
4194
4195         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4196         lex_flags |= LEX_START_COPIED;
4197
4198         if (bytes && SvUTF8(sv))
4199             SvPVbyte_force(sv, len);
4200     }
4201     else if (bytes && SvUTF8(sv)) {
4202         /* Don't modify someone else's scalar */
4203         STRLEN len;
4204         sv = newSVsv(sv);
4205         (void)sv_2mortal(sv);
4206         SvPVbyte_force(sv,len);
4207         lex_flags |= LEX_START_COPIED;
4208     }
4209
4210     TAINT_IF(SvTAINTED(sv));
4211     TAINT_PROPER("eval");
4212
4213     ENTER_with_name("eval");
4214     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4215                            ? LEX_IGNORE_UTF8_HINTS
4216                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4217                         )
4218              );
4219     SAVETMPS;
4220
4221     /* switch to eval mode */
4222
4223     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4224         SV * const temp_sv = sv_newmortal();
4225         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4226                        (unsigned long)++PL_evalseq,
4227                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4228         tmpbuf = SvPVX(temp_sv);
4229         len = SvCUR(temp_sv);
4230     }
4231     else
4232         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4233     SAVECOPFILE_FREE(&PL_compiling);
4234     CopFILE_set(&PL_compiling, tmpbuf+2);
4235     SAVECOPLINE(&PL_compiling);
4236     CopLINE_set(&PL_compiling, 1);
4237     /* special case: an eval '' executed within the DB package gets lexically
4238      * placed in the first non-DB CV rather than the current CV - this
4239      * allows the debugger to execute code, find lexicals etc, in the
4240      * scope of the code being debugged. Passing &seq gets find_runcv
4241      * to do the dirty work for us */
4242     runcv = find_runcv(&seq);
4243
4244     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4245     PUSHEVAL(cx, 0);
4246     cx->blk_eval.retop = PL_op->op_next;
4247
4248     /* prepare to compile string */
4249
4250     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4251         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4252     else {
4253         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4254            deleting the eval's FILEGV from the stash before gv_check() runs
4255            (i.e. before run-time proper). To work around the coredump that
4256            ensues, we always turn GvMULTI_on for any globals that were
4257            introduced within evals. See force_ident(). GSAR 96-10-12 */
4258         char *const safestr = savepvn(tmpbuf, len);
4259         SAVEDELETE(PL_defstash, safestr, len);
4260         saved_delete = TRUE;
4261     }
4262
4263     PUTBACK;
4264
4265     if (doeval(gimme, runcv, seq, saved_hh)) {
4266         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4267             ? (PERLDB_LINE || PERLDB_SAVESRC)
4268             :  PERLDB_SAVESRC_NOSUBS) {
4269             /* Retain the filegv we created.  */
4270         } else if (!saved_delete) {
4271             char *const safestr = savepvn(tmpbuf, len);
4272             SAVEDELETE(PL_defstash, safestr, len);
4273         }
4274         return DOCATCH(PL_eval_start);
4275     } else {
4276         /* We have already left the scope set up earlier thanks to the LEAVE
4277            in doeval().  */
4278         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4279             ? (PERLDB_LINE || PERLDB_SAVESRC)
4280             :  PERLDB_SAVESRC_INVALID) {
4281             /* Retain the filegv we created.  */
4282         } else if (!saved_delete) {
4283             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4284         }
4285         return PL_op->op_next;
4286     }
4287 }
4288
4289 PP(pp_leaveeval)
4290 {
4291     dSP;
4292     SV **newsp;
4293     PMOP *newpm;
4294     I32 gimme;
4295     PERL_CONTEXT *cx;
4296     OP *retop;
4297     const U8 save_flags = PL_op -> op_flags;
4298     I32 optype;
4299     SV *namesv;
4300     CV *evalcv;
4301
4302     PERL_ASYNC_CHECK();
4303     POPBLOCK(cx,newpm);
4304     POPEVAL(cx);
4305     namesv = cx->blk_eval.old_namesv;
4306     retop = cx->blk_eval.retop;
4307     evalcv = cx->blk_eval.cv;
4308
4309     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4310                                 gimme, SVs_TEMP, FALSE);
4311     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4312
4313 #ifdef DEBUGGING
4314     assert(CvDEPTH(evalcv) == 1);
4315 #endif
4316     CvDEPTH(evalcv) = 0;
4317
4318     if (optype == OP_REQUIRE &&
4319         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4320     {
4321         /* Unassume the success we assumed earlier. */
4322         (void)hv_delete(GvHVn(PL_incgv),
4323                         SvPVX_const(namesv),
4324                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4325                         G_DISCARD);
4326         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4327         NOT_REACHED; /* NOTREACHED */
4328         /* die_unwind() did LEAVE, or we won't be here */
4329     }
4330     else {
4331         LEAVE_with_name("eval");
4332         if (!(save_flags & OPf_SPECIAL)) {
4333             CLEAR_ERRSV();
4334         }
4335     }
4336
4337     RETURNOP(retop);
4338 }
4339
4340 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4341    close to the related Perl_create_eval_scope.  */
4342 void
4343 Perl_delete_eval_scope(pTHX)
4344 {
4345     SV **newsp;
4346     PMOP *newpm;
4347     I32 gimme;
4348     PERL_CONTEXT *cx;
4349     I32 optype;
4350
4351     POPBLOCK(cx,newpm);
4352     POPEVAL(cx);
4353     PL_curpm = newpm;
4354     LEAVE_with_name("eval_scope");
4355     PERL_UNUSED_VAR(newsp);
4356     PERL_UNUSED_VAR(gimme);
4357     PERL_UNUSED_VAR(optype);
4358 }
4359
4360 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4361    also needed by Perl_fold_constants.  */
4362 PERL_CONTEXT *
4363 Perl_create_eval_scope(pTHX_ U32 flags)
4364 {
4365     PERL_CONTEXT *cx;
4366     const I32 gimme = GIMME_V;
4367
4368     ENTER_with_name("eval_scope");
4369     SAVETMPS;
4370
4371     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4372     PUSHEVAL(cx, 0);
4373
4374     PL_in_eval = EVAL_INEVAL;
4375     if (flags & G_KEEPERR)
4376         PL_in_eval |= EVAL_KEEPERR;
4377     else
4378         CLEAR_ERRSV();
4379     if (flags & G_FAKINGEVAL) {
4380         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4381     }
4382     return cx;
4383 }
4384
4385 PP(pp_entertry)
4386 {
4387     PERL_CONTEXT * const cx = create_eval_scope(0);
4388     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4389     return DOCATCH(PL_op->op_next);
4390 }
4391
4392 PP(pp_leavetry)
4393 {
4394     dSP;
4395     SV **newsp;
4396     PMOP *newpm;
4397     I32 gimme;
4398     PERL_CONTEXT *cx;
4399     I32 optype;
4400
4401     PERL_ASYNC_CHECK();
4402     POPBLOCK(cx,newpm);
4403     POPEVAL(cx);
4404     PERL_UNUSED_VAR(optype);
4405
4406     SP = leave_common(newsp, SP, newsp, gimme,
4407                                SVs_PADTMP|SVs_TEMP, FALSE);
4408     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4409
4410     LEAVE_with_name("eval_scope");
4411     CLEAR_ERRSV();
4412     RETURN;
4413 }
4414
4415 PP(pp_entergiven)
4416 {
4417     dSP;
4418     PERL_CONTEXT *cx;
4419     const I32 gimme = GIMME_V;
4420
4421     ENTER_with_name("given");
4422     SAVETMPS;
4423
4424     if (PL_op->op_targ) {
4425         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4426         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4427         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4428     }
4429     else {
4430         SAVE_DEFSV;
4431         DEFSV_set(POPs);
4432     }
4433
4434     PUSHBLOCK(cx, CXt_GIVEN, SP);
4435     PUSHGIVEN(cx);
4436
4437     RETURN;
4438 }
4439
4440 PP(pp_leavegiven)
4441 {
4442     dSP;
4443     PERL_CONTEXT *cx;
4444     I32 gimme;
4445     SV **newsp;
4446     PMOP *newpm;
4447     PERL_UNUSED_CONTEXT;
4448
4449     POPBLOCK(cx,newpm);
4450     assert(CxTYPE(cx) == CXt_GIVEN);
4451
4452     SP = leave_common(newsp, SP, newsp, gimme,
4453                                SVs_PADTMP|SVs_TEMP, FALSE);
4454     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4455
4456     LEAVE_with_name("given");
4457     RETURN;
4458 }
4459
4460 /* Helper routines used by pp_smartmatch */
4461 STATIC PMOP *
4462 S_make_matcher(pTHX_ REGEXP *re)
4463 {
4464     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4465
4466     PERL_ARGS_ASSERT_MAKE_MATCHER;
4467
4468     PM_SETRE(matcher, ReREFCNT_inc(re));
4469
4470     SAVEFREEOP((OP *) matcher);
4471     ENTER_with_name("matcher"); SAVETMPS;
4472     SAVEOP();
4473     return matcher;
4474 }
4475
4476 STATIC bool
4477 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4478 {
4479     dSP;
4480
4481     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4482
4483     PL_op = (OP *) matcher;
4484     XPUSHs(sv);
4485     PUTBACK;
4486     (void) Perl_pp_match(aTHX);
4487     SPAGAIN;
4488     return (SvTRUEx(POPs));
4489 }
4490
4491 STATIC void
4492 S_destroy_matcher(pTHX_ PMOP *matcher)
4493 {
4494     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4495     PERL_UNUSED_ARG(matcher);
4496
4497     FREETMPS;
4498     LEAVE_with_name("matcher");
4499 }
4500
4501 /* Do a smart match */
4502 PP(pp_smartmatch)
4503 {
4504     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4505     return do_smartmatch(NULL, NULL, 0);
4506 }
4507
4508 /* This version of do_smartmatch() implements the
4509  * table of smart matches that is found in perlsyn.
4510  */
4511 STATIC OP *
4512 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4513 {
4514     dSP;
4515
4516     bool object_on_left = FALSE;
4517     SV *e = TOPs;       /* e is for 'expression' */
4518     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4519
4520     /* Take care only to invoke mg_get() once for each argument.
4521      * Currently we do this by copying the SV if it's magical. */
4522     if (d) {
4523         if (!copied && SvGMAGICAL(d))
4524             d = sv_mortalcopy(d);
4525     }
4526     else
4527         d = &PL_sv_undef;
4528
4529     assert(e);
4530     if (SvGMAGICAL(e))
4531         e = sv_mortalcopy(e);
4532
4533     /* First of all, handle overload magic of the rightmost argument */
4534     if (SvAMAGIC(e)) {
4535         SV * tmpsv;
4536         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4537         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4538
4539         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4540         if (tmpsv) {
4541             SPAGAIN;
4542             (void)POPs;
4543             SETs(tmpsv);
4544             RETURN;
4545         }
4546         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4547     }
4548
4549     SP -= 2;    /* Pop the values */
4550
4551
4552     /* ~~ undef */
4553     if (!SvOK(e)) {
4554         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4555         if (SvOK(d))
4556             RETPUSHNO;
4557         else
4558             RETPUSHYES;
4559     }
4560
4561     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4562         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4563         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4564     }
4565     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4566         object_on_left = TRUE;
4567
4568     /* ~~ sub */
4569     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4570         I32 c;
4571         if (object_on_left) {
4572             goto sm_any_sub; /* Treat objects like scalars */
4573         }
4574         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4575             /* Test sub truth for each key */
4576             HE *he;
4577             bool andedresults = TRUE;
4578             HV *hv = (HV*) SvRV(d);
4579             I32 numkeys = hv_iterinit(hv);
4580             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4581             if (numkeys == 0)
4582                 RETPUSHYES;
4583             while ( (he = hv_iternext(hv)) ) {
4584                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4585                 ENTER_with_name("smartmatch_hash_key_test");
4586                 SAVETMPS;
4587                 PUSHMARK(SP);
4588                 PUSHs(hv_iterkeysv(he));
4589                 PUTBACK;
4590                 c = call_sv(e, G_SCALAR);
4591                 SPAGAIN;
4592                 if (c == 0)
4593                     andedresults = FALSE;
4594                 else
4595                     andedresults = SvTRUEx(POPs) && andedresults;
4596                 FREETMPS;
4597                 LEAVE_with_name("smartmatch_hash_key_test");
4598             }
4599             if (andedresults)
4600                 RETPUSHYES;
4601             else
4602                 RETPUSHNO;
4603         }
4604         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4605             /* Test sub truth for each element */
4606             SSize_t i;
4607             bool andedresults = TRUE;
4608             AV *av = (AV*) SvRV(d);
4609             const I32 len = av_tindex(av);
4610             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4611             if (len == -1)
4612                 RETPUSHYES;
4613             for (i = 0; i <= len; ++i) {
4614                 SV * const * const svp = av_fetch(av, i, FALSE);
4615                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4616                 ENTER_with_name("smartmatch_array_elem_test");
4617                 SAVETMPS;
4618                 PUSHMARK(SP);
4619                 if (svp)
4620                     PUSHs(*svp);
4621                 PUTBACK;
4622                 c = call_sv(e, G_SCALAR);
4623                 SPAGAIN;
4624                 if (c == 0)
4625                     andedresults = FALSE;
4626                 else
4627                     andedresults = SvTRUEx(POPs) && andedresults;
4628                 FREETMPS;
4629                 LEAVE_with_name("smartmatch_array_elem_test");
4630             }
4631             if (andedresults)
4632                 RETPUSHYES;
4633             else
4634                 RETPUSHNO;
4635         }
4636         else {
4637           sm_any_sub:
4638             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4639             ENTER_with_name("smartmatch_coderef");
4640             SAVETMPS;
4641             PUSHMARK(SP);
4642             PUSHs(d);
4643             PUTBACK;
4644             c = call_sv(e, G_SCALAR);
4645             SPAGAIN;
4646             if (c == 0)
4647                 PUSHs(&PL_sv_no);
4648             else if (SvTEMP(TOPs))
4649                 SvREFCNT_inc_void(TOPs);
4650             FREETMPS;
4651             LEAVE_with_name("smartmatch_coderef");
4652             RETURN;
4653         }
4654     }
4655     /* ~~ %hash */
4656     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4657         if (object_on_left) {
4658             goto sm_any_hash; /* Treat objects like scalars */
4659         }
4660         else if (!SvOK(d)) {
4661             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4662             RETPUSHNO;
4663         }
4664         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4665             /* Check that the key-sets are identical */
4666             HE *he;
4667             HV *other_hv = MUTABLE_HV(SvRV(d));
4668             bool tied;
4669             bool other_tied;
4670             U32 this_key_count  = 0,
4671                 other_key_count = 0;
4672             HV *hv = MUTABLE_HV(SvRV(e));
4673
4674             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4675             /* Tied hashes don't know how many keys they have. */
4676             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4677             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4678             if (!tied ) {
4679                 if(other_tied) {
4680                     /* swap HV sides */
4681                     HV * const temp = other_hv;
4682                     other_hv = hv;
4683                     hv = temp;
4684                     tied = TRUE;
4685                     other_tied = FALSE;
4686                 }
4687                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4688                     RETPUSHNO;
4689             }
4690
4691             /* The hashes have the same number of keys, so it suffices
4692                to check that one is a subset of the other. */
4693             (void) hv_iterinit(hv);
4694             while ( (he = hv_iternext(hv)) ) {
4695                 SV *key = hv_iterkeysv(he);
4696
4697                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4698                 ++ this_key_count;
4699
4700                 if(!hv_exists_ent(other_hv, key, 0)) {
4701                     (void) hv_iterinit(hv);     /* reset iterator */
4702                     RETPUSHNO;
4703                 }
4704             }
4705
4706             if (other_tied) {
4707                 (void) hv_iterinit(other_hv);
4708                 while ( hv_iternext(other_hv) )
4709                     ++other_key_count;
4710             }
4711             else
4712                 other_key_count = HvUSEDKEYS(other_hv);
4713
4714             if (this_key_count != other_key_count)
4715                 RETPUSHNO;
4716             else
4717                 RETPUSHYES;
4718         }
4719         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4720             AV * const other_av = MUTABLE_AV(SvRV(d));
4721             const SSize_t other_len = av_tindex(other_av) + 1;
4722             SSize_t i;
4723             HV *hv = MUTABLE_HV(SvRV(e));
4724
4725             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4726             for (i = 0; i < other_len; ++i) {
4727                 SV ** const svp = av_fetch(other_av, i, FALSE);
4728                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4729                 if (svp) {      /* ??? When can this not happen? */
4730                     if (hv_exists_ent(hv, *svp, 0))
4731                         RETPUSHYES;
4732                 }
4733             }
4734             RETPUSHNO;
4735         }
4736         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4737             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4738           sm_regex_hash:
4739             {
4740                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4741                 HE *he;
4742                 HV *hv = MUTABLE_HV(SvRV(e));
4743
4744                 (void) hv_iterinit(hv);
4745                 while ( (he = hv_iternext(hv)) ) {
4746                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4747                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4748                         (void) hv_iterinit(hv);
4749                         destroy_matcher(matcher);
4750                         RETPUSHYES;
4751                     }
4752                 }
4753                 destroy_matcher(matcher);
4754                 RETPUSHNO;
4755             }
4756         }
4757         else {
4758           sm_any_hash:
4759             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4760             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4761                 RETPUSHYES;
4762             else
4763                 RETPUSHNO;
4764         }
4765     }
4766     /* ~~ @array */
4767     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4768         if (object_on_left) {
4769             goto sm_any_array; /* Treat objects like scalars */
4770         }
4771         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4772             AV * const other_av = MUTABLE_AV(SvRV(e));
4773             const SSize_t other_len = av_tindex(other_av) + 1;
4774             SSize_t i;
4775
4776             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4777             for (i = 0; i < other_len; ++i) {
4778                 SV ** const svp = av_fetch(other_av, i, FALSE);
4779
4780                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4781                 if (svp) {      /* ??? When can this not happen? */
4782                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4783                         RETPUSHYES;
4784                 }
4785             }
4786             RETPUSHNO;
4787         }
4788         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4789             AV *other_av = MUTABLE_AV(SvRV(d));
4790             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4791             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4792                 RETPUSHNO;
4793             else {
4794                 SSize_t i;
4795                 const SSize_t other_len = av_tindex(other_av);
4796
4797                 if (NULL == seen_this) {
4798                     seen_this = newHV();
4799                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4800                 }
4801                 if (NULL == seen_other) {
4802                     seen_other = newHV();
4803                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4804                 }
4805                 for(i = 0; i <= other_len; ++i) {
4806                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4807                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4808
4809                     if (!this_elem || !other_elem) {
4810                         if ((this_elem && SvOK(*this_elem))
4811                                 || (other_elem && SvOK(*other_elem)))
4812                             RETPUSHNO;
4813                     }
4814                     else if (hv_exists_ent(seen_this,
4815                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4816                             hv_exists_ent(seen_other,
4817                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4818                     {
4819                         if (*this_elem != *other_elem)
4820                             RETPUSHNO;
4821                     }
4822                     else {
4823                         (void)hv_store_ent(seen_this,
4824                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4825                                 &PL_sv_undef, 0);
4826                         (void)hv_store_ent(seen_other,
4827                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4828                                 &PL_sv_undef, 0);
4829                         PUSHs(*other_elem);
4830                         PUSHs(*this_elem);
4831
4832                         PUTBACK;
4833                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4834                         (void) do_smartmatch(seen_this, seen_other, 0);
4835                         SPAGAIN;
4836                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4837
4838                         if (!SvTRUEx(POPs))
4839                             RETPUSHNO;
4840                     }
4841                 }
4842                 RETPUSHYES;
4843             }
4844         }
4845         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4846             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4847           sm_regex_array:
4848             {
4849                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4850                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4851                 SSize_t i;
4852
4853                 for(i = 0; i <= this_len; ++i) {
4854                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4855                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4856                     if (svp && matcher_matches_sv(matcher, *svp)) {
4857                         destroy_matcher(matcher);
4858                         RETPUSHYES;
4859                     }
4860                 }
4861                 destroy_matcher(matcher);
4862                 RETPUSHNO;
4863             }
4864         }
4865         else if (!SvOK(d)) {
4866             /* undef ~~ array */
4867             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4868             SSize_t i;
4869
4870             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4871             for (i = 0; i <= this_len; ++i) {
4872                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4873                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4874                 if (!svp || !SvOK(*svp))
4875                     RETPUSHYES;
4876             }
4877             RETPUSHNO;
4878         }
4879         else {
4880           sm_any_array:
4881             {
4882                 SSize_t i;
4883                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4884
4885                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4886                 for (i = 0; i <= this_len; ++i) {
4887                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4888                     if (!svp)
4889                         continue;
4890
4891                     PUSHs(d);
4892                     PUSHs(*svp);
4893                     PUTBACK;
4894                     /* infinite recursion isn't supposed to happen here */
4895                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4896                     (void) do_smartmatch(NULL, NULL, 1);
4897                     SPAGAIN;
4898                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4899                     if (SvTRUEx(POPs))
4900                         RETPUSHYES;
4901                 }
4902                 RETPUSHNO;
4903             }
4904         }
4905     }
4906     /* ~~ qr// */
4907     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4908         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4909             SV *t = d; d = e; e = t;
4910             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4911             goto sm_regex_hash;
4912         }
4913         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4914             SV *t = d; d = e; e = t;
4915             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4916             goto sm_regex_array;
4917         }
4918         else {
4919             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4920
4921             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4922             PUTBACK;
4923             PUSHs(matcher_matches_sv(matcher, d)
4924                     ? &PL_sv_yes
4925                     : &PL_sv_no);
4926             destroy_matcher(matcher);
4927             RETURN;
4928         }
4929     }
4930     /* ~~ scalar */
4931     /* See if there is overload magic on left */
4932     else if (object_on_left && SvAMAGIC(d)) {
4933         SV *tmpsv;
4934         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4935         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4936         PUSHs(d); PUSHs(e);
4937         PUTBACK;
4938         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4939         if (tmpsv) {
4940             SPAGAIN;
4941             (void)POPs;
4942             SETs(tmpsv);
4943             RETURN;
4944         }
4945         SP -= 2;
4946         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4947         goto sm_any_scalar;
4948     }
4949     else if (!SvOK(d)) {
4950         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4951         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4952         RETPUSHNO;
4953     }
4954     else
4955   sm_any_scalar:
4956     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4957         DEBUG_M(if (SvNIOK(e))
4958                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4959                 else
4960                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4961         );
4962         /* numeric comparison */
4963         PUSHs(d); PUSHs(e);
4964         PUTBACK;
4965         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4966             (void) Perl_pp_i_eq(aTHX);
4967         else
4968             (void) Perl_pp_eq(aTHX);
4969         SPAGAIN;
4970         if (SvTRUEx(POPs))
4971             RETPUSHYES;
4972         else
4973             RETPUSHNO;
4974     }
4975
4976     /* As a last resort, use string comparison */
4977     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4978     PUSHs(d); PUSHs(e);
4979     PUTBACK;
4980     return Perl_pp_seq(aTHX);
4981 }
4982
4983 PP(pp_enterwhen)
4984 {
4985     dSP;
4986     PERL_CONTEXT *cx;
4987     const I32 gimme = GIMME_V;
4988
4989     /* This is essentially an optimization: if the match
4990        fails, we don't want to push a context and then
4991        pop it again right away, so we skip straight
4992        to the op that follows the leavewhen.
4993        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4994     */
4995     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4996         RETURNOP(cLOGOP->op_other->op_next);
4997
4998     ENTER_with_name("when");
4999     SAVETMPS;
5000
5001     PUSHBLOCK(cx, CXt_WHEN, SP);
5002     PUSHWHEN(cx);
5003
5004     RETURN;
5005 }
5006
5007 PP(pp_leavewhen)
5008 {
5009     dSP;
5010     I32 cxix;
5011     PERL_CONTEXT *cx;
5012     I32 gimme;
5013     SV **newsp;
5014     PMOP *newpm;
5015
5016     cxix = dopoptogiven(cxstack_ix);
5017     if (cxix < 0)
5018         /* diag_listed_as: Can't "when" outside a topicalizer */
5019         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5020                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5021
5022     POPBLOCK(cx,newpm);
5023     assert(CxTYPE(cx) == CXt_WHEN);
5024
5025     SP = leave_common(newsp, SP, newsp, gimme,
5026                                SVs_PADTMP|SVs_TEMP, FALSE);
5027     PL_curpm = newpm;   /* pop $1 et al */
5028
5029     LEAVE_with_name("when");
5030
5031     if (cxix < cxstack_ix)
5032         dounwind(cxix);
5033
5034     cx = &cxstack[cxix];
5035
5036     if (CxFOREACH(cx)) {
5037         /* clear off anything above the scope we're re-entering */
5038         I32 inner = PL_scopestack_ix;
5039
5040         TOPBLOCK(cx);
5041         if (PL_scopestack_ix < inner)
5042             leave_scope(PL_scopestack[PL_scopestack_ix]);
5043         PL_curcop = cx->blk_oldcop;
5044
5045         PERL_ASYNC_CHECK();
5046         return cx->blk_loop.my_op->op_nextop;
5047     }
5048     else {
5049         PERL_ASYNC_CHECK();
5050         RETURNOP(cx->blk_givwhen.leave_op);
5051     }
5052 }
5053
5054 PP(pp_continue)
5055 {
5056     dSP;
5057     I32 cxix;
5058     PERL_CONTEXT *cx;
5059     I32 gimme;
5060     SV **newsp;
5061     PMOP *newpm;
5062
5063     PERL_UNUSED_VAR(gimme);
5064
5065     cxix = dopoptowhen(cxstack_ix);
5066     if (cxix < 0)
5067         DIE(aTHX_ "Can't \"continue\" outside a when block");
5068
5069     if (cxix < cxstack_ix)
5070         dounwind(cxix);
5071
5072     POPBLOCK(cx,newpm);
5073     assert(CxTYPE(cx) == CXt_WHEN);
5074
5075     SP = newsp;
5076     PL_curpm = newpm;   /* pop $1 et al */
5077
5078     LEAVE_with_name("when");
5079     RETURNOP(cx->blk_givwhen.leave_op->op_next);
5080 }
5081
5082 PP(pp_break)
5083 {
5084     I32 cxix;
5085     PERL_CONTEXT *cx;
5086
5087     cxix = dopoptogiven(cxstack_ix);
5088     if (cxix < 0)
5089         DIE(aTHX_ "Can't \"break\" outside a given block");
5090
5091     cx = &cxstack[cxix];
5092     if (CxFOREACH(cx))
5093         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5094
5095     if (cxix < cxstack_ix)
5096         dounwind(cxix);
5097
5098     /* Restore the sp at the time we entered the given block */
5099     TOPBLOCK(cx);
5100
5101     return cx->blk_givwhen.leave_op;
5102 }
5103
5104 static MAGIC *
5105 S_doparseform(pTHX_ SV *sv)
5106 {
5107     STRLEN len;
5108     char *s = SvPV(sv, len);
5109     char *send;
5110     char *base = NULL; /* start of current field */
5111     I32 skipspaces = 0; /* number of contiguous spaces seen */
5112     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5113     bool repeat    = FALSE; /* ~~ seen on this line */
5114     bool postspace = FALSE; /* a text field may need right padding */
5115     U32 *fops;
5116     U32 *fpc;
5117     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5118     I32 arg;
5119     bool ischop;            /* it's a ^ rather than a @ */
5120     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5121     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5122     MAGIC *mg = NULL;
5123     SV *sv_copy;
5124
5125     PERL_ARGS_ASSERT_DOPARSEFORM;
5126
5127     if (len == 0)
5128         Perl_croak(aTHX_ "Null picture in formline");
5129
5130     if (SvTYPE(sv) >= SVt_PVMG) {
5131         /* This might, of course, still return NULL.  */
5132         mg = mg_find(sv, PERL_MAGIC_fm);
5133     } else {
5134         sv_upgrade(sv, SVt_PVMG);
5135     }
5136
5137     if (mg) {
5138         /* still the same as previously-compiled string? */
5139         SV *old = mg->mg_obj;
5140         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5141               && len == SvCUR(old)
5142               && strnEQ(SvPVX(old), SvPVX(sv), len)
5143         ) {
5144             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5145             return mg;
5146         }
5147
5148         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5149         Safefree(mg->mg_ptr);
5150         mg->mg_ptr = NULL;
5151         SvREFCNT_dec(old);
5152         mg->mg_obj = NULL;
5153     }
5154     else {
5155         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5156         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5157     }
5158
5159     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5160     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5161     send = s + len;
5162
5163
5164     /* estimate the buffer size needed */
5165     for (base = s; s <= send; s++) {
5166         if (*s == '\n' || *s == '@' || *s == '^')
5167             maxops += 10;
5168     }
5169     s = base;
5170     base = NULL;
5171
5172     Newx(fops, maxops, U32);
5173     fpc = fops;
5174
5175     if (s < send) {
5176         linepc = fpc;
5177         *fpc++ = FF_LINEMARK;
5178         noblank = repeat = FALSE;
5179         base = s;
5180     }
5181
5182     while (s <= send) {
5183         switch (*s++) {
5184         default:
5185             skipspaces = 0;
5186             continue;
5187
5188         case '~':
5189             if (*s == '~') {
5190                 repeat = TRUE;
5191                 skipspaces++;
5192                 s++;
5193             }
5194             noblank = TRUE;
5195             /* FALLTHROUGH */
5196         case ' ': case '\t':
5197             skipspaces++;
5198             continue;
5199         case 0:
5200             if (s < send) {
5201                 skipspaces = 0;
5202                 continue;
5203             } /* else FALL THROUGH */
5204         case '\n':
5205             arg = s - base;
5206             skipspaces++;
5207             arg -= skipspaces;
5208             if (arg) {
5209                 if (postspace)
5210                     *fpc++ = FF_SPACE;
5211                 *fpc++ = FF_LITERAL;
5212                 *fpc++ = (U32)arg;
5213             }
5214             postspace = FALSE;
5215             if (s <= send)
5216                 skipspaces--;
5217             if (skipspaces) {
5218                 *fpc++ = FF_SKIP;
5219                 *fpc++ = (U32)skipspaces;
5220             }
5221             skipspaces = 0;
5222             if (s <= send)
5223                 *fpc++ = FF_NEWLINE;
5224             if (noblank) {
5225                 *fpc++ = FF_BLANK;
5226                 if (repeat)
5227                     arg = fpc - linepc + 1;
5228                 else
5229                     arg = 0;
5230                 *fpc++ = (U32)arg;
5231             }
5232             if (s < send) {
5233                 linepc = fpc;
5234                 *fpc++ = FF_LINEMARK;
5235                 noblank = repeat = FALSE;
5236                 base = s;
5237             }
5238             else
5239                 s++;
5240             continue;
5241
5242         case '@':
5243         case '^':
5244             ischop = s[-1] == '^';
5245
5246             if (postspace) {
5247                 *fpc++ = FF_SPACE;
5248                 postspace = FALSE;
5249             }
5250             arg = (s - base) - 1;
5251             if (arg) {
5252                 *fpc++ = FF_LITERAL;
5253                 *fpc++ = (U32)arg;
5254             }
5255
5256             base = s - 1;
5257             *fpc++ = FF_FETCH;
5258             if (*s == '*') { /*  @* or ^*  */
5259                 s++;
5260                 *fpc++ = 2;  /* skip the @* or ^* */
5261                 if (ischop) {
5262                     *fpc++ = FF_LINESNGL;
5263                     *fpc++ = FF_CHOP;
5264                 } else
5265                     *fpc++ = FF_LINEGLOB;
5266             }
5267             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5268                 arg = ischop ? FORM_NUM_BLANK : 0;
5269                 base = s - 1;
5270                 while (*s == '#')
5271                     s++;
5272                 if (*s == '.') {
5273                     const char * const f = ++s;
5274                     while (*s == '#')
5275                         s++;
5276                     arg |= FORM_NUM_POINT + (s - f);
5277                 }
5278                 *fpc++ = s - base;              /* fieldsize for FETCH */
5279                 *fpc++ = FF_DECIMAL;
5280                 *fpc++ = (U32)arg;
5281                 unchopnum |= ! ischop;
5282             }
5283             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5284                 arg = ischop ? FORM_NUM_BLANK : 0;
5285                 base = s - 1;
5286                 s++;                                /* skip the '0' first */
5287                 while (*s == '#')
5288                     s++;
5289                 if (*s == '.') {
5290                     const char * const f = ++s;
5291                     while (*s == '#')
5292                         s++;
5293                     arg |= FORM_NUM_POINT + (s - f);
5294                 }
5295                 *fpc++ = s - base;                /* fieldsize for FETCH */
5296                 *fpc++ = FF_0DECIMAL;
5297                 *fpc++ = (U32)arg;
5298                 unchopnum |= ! ischop;
5299             }
5300             else {                              /* text field */
5301                 I32 prespace = 0;
5302                 bool ismore = FALSE;
5303
5304                 if (*s == '>') {
5305                     while (*++s == '>') ;
5306                     prespace = FF_SPACE;
5307                 }
5308                 else if (*s == '|') {
5309                     while (*++s == '|') ;
5310                     prespace = FF_HALFSPACE;
5311                     postspace = TRUE;
5312                 }
5313                 else {
5314                     if (*s == '<')
5315                         while (*++s == '<') ;
5316                     postspace = TRUE;
5317                 }
5318                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5319                     s += 3;
5320                     ismore = TRUE;
5321                 }
5322                 *fpc++ = s - base;              /* fieldsize for FETCH */
5323
5324                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5325
5326                 if (prespace)
5327                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5328                 *fpc++ = FF_ITEM;
5329                 if (ismore)
5330                     *fpc++ = FF_MORE;
5331                 if (ischop)
5332                     *fpc++ = FF_CHOP;
5333             }
5334             base = s;
5335             skipspaces = 0;
5336             continue;
5337         }
5338     }
5339     *fpc++ = FF_END;
5340
5341     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5342     arg = fpc - fops;
5343
5344     mg->mg_ptr = (char *) fops;
5345     mg->mg_len = arg * sizeof(U32);
5346     mg->mg_obj = sv_copy;
5347     mg->mg_flags |= MGf_REFCOUNTED;
5348
5349     if (unchopnum && repeat)
5350         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5351
5352     return mg;
5353 }
5354
5355
5356 STATIC bool
5357 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5358 {
5359     /* Can value be printed in fldsize chars, using %*.*f ? */
5360     NV pwr = 1;
5361     NV eps = 0.5;
5362     bool res = FALSE;
5363     int intsize = fldsize - (value < 0 ? 1 : 0);
5364
5365     if (frcsize & FORM_NUM_POINT)
5366         intsize--;
5367     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5368     intsize -= frcsize;
5369
5370     while (intsize--) pwr *= 10.0;
5371     while (frcsize--) eps /= 10.0;
5372
5373     if( value >= 0 ){
5374         if (value + eps >= pwr)
5375             res = TRUE;
5376     } else {
5377         if (value - eps <= -pwr)
5378             res = TRUE;
5379     }
5380     return res;
5381 }
5382
5383 static I32
5384 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5385 {
5386     SV * const datasv = FILTER_DATA(idx);
5387     const int filter_has_file = IoLINES(datasv);
5388     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5389     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5390     int status = 0;
5391     SV *upstream;
5392     STRLEN got_len;
5393     char *got_p = NULL;
5394     char *prune_from = NULL;
5395     bool read_from_cache = FALSE;
5396     STRLEN umaxlen;
5397     SV *err = NULL;
5398
5399     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5400
5401     assert(maxlen >= 0);
5402     umaxlen = maxlen;
5403
5404     /* I was having segfault trouble under Linux 2.2.5 after a
5405        parse error occured.  (Had to hack around it with a test
5406        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5407        not sure where the trouble is yet.  XXX */
5408
5409     {
5410         SV *const cache = datasv;
5411         if (SvOK(cache)) {
5412             STRLEN cache_len;
5413             const char *cache_p = SvPV(cache, cache_len);
5414             STRLEN take = 0;
5415
5416             if (umaxlen) {
5417                 /* Running in block mode and we have some cached data already.
5418                  */
5419                 if (cache_len >= umaxlen) {
5420                     /* In fact, so much data we don't even need to call
5421                        filter_read.  */
5422                     take = umaxlen;
5423                 }
5424             } else {
5425                 const char *const first_nl =
5426                     (const char *)memchr(cache_p, '\n', cache_len);
5427                 if (first_nl) {
5428                     take = first_nl + 1 - cache_p;
5429                 }
5430             }
5431             if (take) {
5432                 sv_catpvn(buf_sv, cache_p, take);
5433                 sv_chop(cache, cache_p + take);
5434                 /* Definitely not EOF  */
5435                 return 1;
5436             }
5437
5438             sv_catsv(buf_sv, cache);
5439             if (umaxlen) {
5440                 umaxlen -= cache_len;
5441             }
5442             SvOK_off(cache);
5443             read_from_cache = TRUE;
5444         }
5445     }
5446
5447     /* Filter API says that the filter appends to the contents of the buffer.
5448        Usually the buffer is "", so the details don't matter. But if it's not,
5449        then clearly what it contains is already filtered by this filter, so we
5450        don't want to pass it in a second time.
5451        I'm going to use a mortal in case the upstream filter croaks.  */
5452     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5453         ? sv_newmortal() : buf_sv;
5454     SvUPGRADE(upstream, SVt_PV);
5455
5456     if (filter_has_file) {
5457         status = FILTER_READ(idx+1, upstream, 0);
5458     }
5459
5460     if (filter_sub && status >= 0) {
5461         dSP;
5462         int count;
5463
5464         ENTER_with_name("call_filter_sub");
5465         SAVE_DEFSV;
5466         SAVETMPS;
5467         EXTEND(SP, 2);
5468
5469         DEFSV_set(upstream);
5470         PUSHMARK(SP);
5471         mPUSHi(0);
5472         if (filter_state) {
5473             PUSHs(filter_state);
5474         }
5475         PUTBACK;
5476         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5477         SPAGAIN;
5478
5479         if (count > 0) {
5480             SV *out = POPs;
5481             SvGETMAGIC(out);
5482             if (SvOK(out)) {
5483                 status = SvIV(out);
5484             }
5485             else {
5486                 SV * const errsv = ERRSV;
5487                 if (SvTRUE_NN(errsv))
5488                     err = newSVsv(errsv);
5489             }
5490         }
5491
5492         PUTBACK;
5493         FREETMPS;
5494         LEAVE_with_name("call_filter_sub");
5495     }
5496
5497     if (SvGMAGICAL(upstream)) {
5498         mg_get(upstream);
5499         if (upstream == buf_sv) mg_free(buf_sv);
5500     }
5501     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5502     if(!err && SvOK(upstream)) {
5503         got_p = SvPV_nomg(upstream, got_len);
5504         if (umaxlen) {
5505             if (got_len > umaxlen) {
5506                 prune_from = got_p + umaxlen;
5507             }
5508         } else {
5509             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5510             if (first_nl && first_nl + 1 < got_p + got_len) {
5511                 /* There's a second line here... */
5512                 prune_from = first_nl + 1;
5513             }
5514         }
5515     }
5516     if (!err && prune_from) {
5517         /* Oh. Too long. Stuff some in our cache.  */
5518         STRLEN cached_len = got_p + got_len - prune_from;
5519         SV *const cache = datasv;
5520
5521         if (SvOK(cache)) {
5522             /* Cache should be empty.  */
5523             assert(!SvCUR(cache));
5524         }
5525
5526         sv_setpvn(cache, prune_from, cached_len);
5527         /* If you ask for block mode, you may well split UTF-8 characters.
5528            "If it breaks, you get to keep both parts"
5529            (Your code is broken if you  don't put them back together again
5530            before something notices.) */
5531         if (SvUTF8(upstream)) {
5532             SvUTF8_on(cache);
5533         }
5534         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5535         else
5536             /* Cannot just use sv_setpvn, as that could free the buffer
5537                before we have a chance to assign it. */
5538             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5539                       got_len - cached_len);
5540         *prune_from = 0;
5541         /* Can't yet be EOF  */
5542         if (status == 0)
5543             status = 1;
5544     }
5545
5546     /* If they are at EOF but buf_sv has something in it, then they may never
5547        have touched the SV upstream, so it may be undefined.  If we naively
5548        concatenate it then we get a warning about use of uninitialised value.
5549     */
5550     if (!err && upstream != buf_sv &&
5551         SvOK(upstream)) {
5552         sv_catsv_nomg(buf_sv, upstream);
5553     }
5554     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5555
5556     if (status <= 0) {
5557         IoLINES(datasv) = 0;
5558         if (filter_state) {
5559             SvREFCNT_dec(filter_state);
5560             IoTOP_GV(datasv) = NULL;
5561         }
5562         if (filter_sub) {
5563             SvREFCNT_dec(filter_sub);
5564             IoBOTTOM_GV(datasv) = NULL;
5565         }
5566         filter_del(S_run_user_filter);
5567     }
5568
5569     if (err)
5570         croak_sv(err);
5571
5572     if (status == 0 && read_from_cache) {
5573         /* If we read some data from the cache (and by getting here it implies
5574            that we emptied the cache) then we aren't yet at EOF, and mustn't
5575            report that to our caller.  */
5576         return 1;
5577     }
5578     return status;
5579 }
5580
5581 /*
5582  * Local variables:
5583  * c-indentation-style: bsd
5584  * c-basic-offset: 4
5585  * indent-tabs-mode: nil
5586  * End:
5587  *
5588  * ex: set ts=8 sts=4 sw=4 et:
5589  */