pp_ctl.c

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