pp_ctl.c

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