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