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