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