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