pp_ctl.c

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