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