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