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