pp_ctl.c

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