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