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