pp_ctl.c

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