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             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1398                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1399             if (CxTYPE(cx) == CXt_NULL)
1400                 return -1;
1401             break;
1402         case CXt_LOOP_LAZYIV:
1403         case CXt_LOOP_LAZYSV:
1404         case CXt_LOOP_FOR:
1405         case CXt_LOOP_PLAIN:
1406           {
1407             const char *cx_label = CxLABEL(cx);
1408             if (!cx_label || strNE(label, cx_label) ) {
1409                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1410                         (long)i, cx_label));
1411                 continue;
1412             }
1413             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1414             return i;
1415           }
1416         }
1417     }
1418     return i;
1419 }
1420
1421
1422
1423 I32
1424 Perl_dowantarray(pTHX)
1425 {
1426     dVAR;
1427     const I32 gimme = block_gimme();
1428     return (gimme == G_VOID) ? G_SCALAR : gimme;
1429 }
1430
1431 I32
1432 Perl_block_gimme(pTHX)
1433 {
1434     dVAR;
1435     const I32 cxix = dopoptosub(cxstack_ix);
1436     if (cxix < 0)
1437         return G_VOID;
1438
1439     switch (cxstack[cxix].blk_gimme) {
1440     case G_VOID:
1441         return G_VOID;
1442     case G_SCALAR:
1443         return G_SCALAR;
1444     case G_ARRAY:
1445         return G_ARRAY;
1446     default:
1447         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1448         /* NOTREACHED */
1449         return 0;
1450     }
1451 }
1452
1453 I32
1454 Perl_is_lvalue_sub(pTHX)
1455 {
1456     dVAR;
1457     const I32 cxix = dopoptosub(cxstack_ix);
1458     assert(cxix >= 0);  /* We should only be called from inside subs */
1459
1460     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1461         return CxLVAL(cxstack + cxix);
1462     else
1463         return 0;
1464 }
1465
1466 /* only used by PUSHSUB */
1467 I32
1468 Perl_was_lvalue_sub(pTHX)
1469 {
1470     dVAR;
1471     const I32 cxix = dopoptosub(cxstack_ix-1);
1472     assert(cxix >= 0);  /* We should only be called from inside subs */
1473
1474     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1475         return CxLVAL(cxstack + cxix);
1476     else
1477         return 0;
1478 }
1479
1480 STATIC I32
1481 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1482 {
1483     dVAR;
1484     I32 i;
1485
1486     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1487
1488     for (i = startingblock; i >= 0; i--) {
1489         register const PERL_CONTEXT * const cx = &cxstk[i];
1490         switch (CxTYPE(cx)) {
1491         default:
1492             continue;
1493         case CXt_EVAL:
1494         case CXt_SUB:
1495         case CXt_FORMAT:
1496             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1497             return i;
1498         }
1499     }
1500     return i;
1501 }
1502
1503 STATIC I32
1504 S_dopoptoeval(pTHX_ I32 startingblock)
1505 {
1506     dVAR;
1507     I32 i;
1508     for (i = startingblock; i >= 0; i--) {
1509         register const PERL_CONTEXT *cx = &cxstack[i];
1510         switch (CxTYPE(cx)) {
1511         default:
1512             continue;
1513         case CXt_EVAL:
1514             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1515             return i;
1516         }
1517     }
1518     return i;
1519 }
1520
1521 STATIC I32
1522 S_dopoptoloop(pTHX_ I32 startingblock)
1523 {
1524     dVAR;
1525     I32 i;
1526     for (i = startingblock; i >= 0; i--) {
1527         register const PERL_CONTEXT * const cx = &cxstack[i];
1528         switch (CxTYPE(cx)) {
1529         case CXt_SUBST:
1530         case CXt_SUB:
1531         case CXt_FORMAT:
1532         case CXt_EVAL:
1533         case CXt_NULL:
1534             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1535                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1536             if ((CxTYPE(cx)) == CXt_NULL)
1537                 return -1;
1538             break;
1539         case CXt_LOOP_LAZYIV:
1540         case CXt_LOOP_LAZYSV:
1541         case CXt_LOOP_FOR:
1542         case CXt_LOOP_PLAIN:
1543             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1544             return i;
1545         }
1546     }
1547     return i;
1548 }
1549
1550 STATIC I32
1551 S_dopoptogiven(pTHX_ I32 startingblock)
1552 {
1553     dVAR;
1554     I32 i;
1555     for (i = startingblock; i >= 0; i--) {
1556         register const PERL_CONTEXT *cx = &cxstack[i];
1557         switch (CxTYPE(cx)) {
1558         default:
1559             continue;
1560         case CXt_GIVEN:
1561             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1562             return i;
1563         case CXt_LOOP_PLAIN:
1564             assert(!CxFOREACHDEF(cx));
1565             break;
1566         case CXt_LOOP_LAZYIV:
1567         case CXt_LOOP_LAZYSV:
1568         case CXt_LOOP_FOR:
1569             if (CxFOREACHDEF(cx)) {
1570                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1571                 return i;
1572             }
1573         }
1574     }
1575     return i;
1576 }
1577
1578 STATIC I32
1579 S_dopoptowhen(pTHX_ I32 startingblock)
1580 {
1581     dVAR;
1582     I32 i;
1583     for (i = startingblock; i >= 0; i--) {
1584         register const PERL_CONTEXT *cx = &cxstack[i];
1585         switch (CxTYPE(cx)) {
1586         default:
1587             continue;
1588         case CXt_WHEN:
1589             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1590             return i;
1591         }
1592     }
1593     return i;
1594 }
1595
1596 void
1597 Perl_dounwind(pTHX_ I32 cxix)
1598 {
1599     dVAR;
1600     I32 optype;
1601
1602     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1603         return;
1604
1605     while (cxstack_ix > cxix) {
1606         SV *sv;
1607         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1608         DEBUG_CX("UNWIND");                                             \
1609         /* Note: we don't need to restore the base context info till the end. */
1610         switch (CxTYPE(cx)) {
1611         case CXt_SUBST:
1612             POPSUBST(cx);
1613             continue;  /* not break */
1614         case CXt_SUB:
1615             POPSUB(cx,sv);
1616             LEAVESUB(sv);
1617             break;
1618         case CXt_EVAL:
1619             POPEVAL(cx);
1620             break;
1621         case CXt_LOOP_LAZYIV:
1622         case CXt_LOOP_LAZYSV:
1623         case CXt_LOOP_FOR:
1624         case CXt_LOOP_PLAIN:
1625             POPLOOP(cx);
1626             break;
1627         case CXt_NULL:
1628             break;
1629         case CXt_FORMAT:
1630             POPFORMAT(cx);
1631             break;
1632         }
1633         cxstack_ix--;
1634     }
1635     PERL_UNUSED_VAR(optype);
1636 }
1637
1638 void
1639 Perl_qerror(pTHX_ SV *err)
1640 {
1641     dVAR;
1642
1643     PERL_ARGS_ASSERT_QERROR;
1644
1645     if (PL_in_eval) {
1646         if (PL_in_eval & EVAL_KEEPERR) {
1647                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1648                                                     SVfARG(err));
1649         }
1650         else
1651             sv_catsv(ERRSV, err);
1652     }
1653     else if (PL_errors)
1654         sv_catsv(PL_errors, err);
1655     else
1656         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1657     if (PL_parser)
1658         ++PL_parser->error_count;
1659 }
1660
1661 void
1662 Perl_die_unwind(pTHX_ SV *msv)
1663 {
1664     dVAR;
1665     SV *exceptsv = sv_mortalcopy(msv);
1666     U8 in_eval = PL_in_eval;
1667     PERL_ARGS_ASSERT_DIE_UNWIND;
1668
1669     if (in_eval) {
1670         I32 cxix;
1671         I32 gimme;
1672
1673         /*
1674          * Historically, perl used to set ERRSV ($@) early in the die
1675          * process and rely on it not getting clobbered during unwinding.
1676          * That sucked, because it was liable to get clobbered, so the
1677          * setting of ERRSV used to emit the exception from eval{} has
1678          * been moved to much later, after unwinding (see just before
1679          * JMPENV_JUMP below).  However, some modules were relying on the
1680          * early setting, by examining $@ during unwinding to use it as
1681          * a flag indicating whether the current unwinding was caused by
1682          * an exception.  It was never a reliable flag for that purpose,
1683          * being totally open to false positives even without actual
1684          * clobberage, but was useful enough for production code to
1685          * semantically rely on it.
1686          *
1687          * We'd like to have a proper introspective interface that
1688          * explicitly describes the reason for whatever unwinding
1689          * operations are currently in progress, so that those modules
1690          * work reliably and $@ isn't further overloaded.  But we don't
1691          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1692          * now *additionally* set here, before unwinding, to serve as the
1693          * (unreliable) flag that it used to.
1694          *
1695          * This behaviour is temporary, and should be removed when a
1696          * proper way to detect exceptional unwinding has been developed.
1697          * As of 2010-12, the authors of modules relying on the hack
1698          * are aware of the issue, because the modules failed on
1699          * perls 5.13.{1..7} which had late setting of $@ without this
1700          * early-setting hack.
1701          */
1702         if (!(in_eval & EVAL_KEEPERR)) {
1703             SvTEMP_off(exceptsv);
1704             sv_setsv(ERRSV, exceptsv);
1705         }
1706
1707         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1708                && PL_curstackinfo->si_prev)
1709         {
1710             dounwind(-1);
1711             POPSTACK;
1712         }
1713
1714         if (cxix >= 0) {
1715             I32 optype;
1716             SV *namesv;
1717             register PERL_CONTEXT *cx;
1718             SV **newsp;
1719             COP *oldcop;
1720             JMPENV *restartjmpenv;
1721             OP *restartop;
1722
1723             if (cxix < cxstack_ix)
1724                 dounwind(cxix);
1725
1726             POPBLOCK(cx,PL_curpm);
1727             if (CxTYPE(cx) != CXt_EVAL) {
1728                 STRLEN msglen;
1729                 const char* message = SvPVx_const(exceptsv, msglen);
1730                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1731                 PerlIO_write(Perl_error_log, message, msglen);
1732                 my_exit(1);
1733             }
1734             POPEVAL(cx);
1735             namesv = cx->blk_eval.old_namesv;
1736             oldcop = cx->blk_oldcop;
1737             restartjmpenv = cx->blk_eval.cur_top_env;
1738             restartop = cx->blk_eval.retop;
1739
1740             if (gimme == G_SCALAR)
1741                 *++newsp = &PL_sv_undef;
1742             PL_stack_sp = newsp;
1743
1744             LEAVE;
1745
1746             /* LEAVE could clobber PL_curcop (see save_re_context())
1747              * XXX it might be better to find a way to avoid messing with
1748              * PL_curcop in save_re_context() instead, but this is a more
1749              * minimal fix --GSAR */
1750             PL_curcop = oldcop;
1751
1752             if (optype == OP_REQUIRE) {
1753                 (void)hv_store(GvHVn(PL_incgv),
1754                                SvPVX_const(namesv),
1755                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1756                                &PL_sv_undef, 0);
1757                 /* note that unlike pp_entereval, pp_require isn't
1758                  * supposed to trap errors. So now that we've popped the
1759                  * EVAL that pp_require pushed, and processed the error
1760                  * message, rethrow the error */
1761                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1762                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1763                                                                     SVs_TEMP)));
1764             }
1765             if (in_eval & EVAL_KEEPERR) {
1766                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1767                                SVfARG(exceptsv));
1768             }
1769             else {
1770                 sv_setsv(ERRSV, exceptsv);
1771             }
1772             PL_restartjmpenv = restartjmpenv;
1773             PL_restartop = restartop;
1774             JMPENV_JUMP(3);
1775             /* NOTREACHED */
1776         }
1777     }
1778
1779     write_to_stderr(exceptsv);
1780     my_failure_exit();
1781     /* NOTREACHED */
1782 }
1783
1784 PP(pp_xor)
1785 {
1786     dVAR; dSP; dPOPTOPssrl;
1787     if (SvTRUE(left) != SvTRUE(right))
1788         RETSETYES;
1789     else
1790         RETSETNO;
1791 }
1792
1793 /*
1794 =for apidoc caller_cx
1795
1796 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1797 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1798 information returned to Perl by C<caller>. Note that XSUBs don't get a
1799 stack frame, so C<caller_cx(0, NULL)> will return information for the
1800 immediately-surrounding Perl code.
1801
1802 This function skips over the automatic calls to C<&DB::sub> made on the
1803 behalf of the debugger. If the stack frame requested was a sub called by
1804 C<DB::sub>, the return value will be the frame for the call to
1805 C<DB::sub>, since that has the correct line number/etc. for the call
1806 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1807 frame for the sub call itself.
1808
1809 =cut
1810 */
1811
1812 const PERL_CONTEXT *
1813 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1814 {
1815     register I32 cxix = dopoptosub(cxstack_ix);
1816     register const PERL_CONTEXT *cx;
1817     register const PERL_CONTEXT *ccstack = cxstack;
1818     const PERL_SI *top_si = PL_curstackinfo;
1819
1820     for (;;) {
1821         /* we may be in a higher stacklevel, so dig down deeper */
1822         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1823             top_si = top_si->si_prev;
1824             ccstack = top_si->si_cxstack;
1825             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1826         }
1827         if (cxix < 0)
1828             return NULL;
1829         /* caller() should not report the automatic calls to &DB::sub */
1830         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1831                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1832             count++;
1833         if (!count--)
1834             break;
1835         cxix = dopoptosub_at(ccstack, cxix - 1);
1836     }
1837
1838     cx = &ccstack[cxix];
1839     if (dbcxp) *dbcxp = cx;
1840
1841     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1842         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1843         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1844            field below is defined for any cx. */
1845         /* caller() should not report the automatic calls to &DB::sub */
1846         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1847             cx = &ccstack[dbcxix];
1848     }
1849
1850     return cx;
1851 }
1852
1853 PP(pp_caller)
1854 {
1855     dVAR;
1856     dSP;
1857     register const PERL_CONTEXT *cx;
1858     const PERL_CONTEXT *dbcx;
1859     I32 gimme;
1860     const HEK *stash_hek;
1861     I32 count = 0;
1862     bool has_arg = MAXARG && TOPs;
1863
1864     if (MAXARG) {
1865       if (has_arg)
1866         count = POPi;
1867       else (void)POPs;
1868     }
1869
1870     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1871     if (!cx) {
1872         if (GIMME != G_ARRAY) {
1873             EXTEND(SP, 1);
1874             RETPUSHUNDEF;
1875         }
1876         RETURN;
1877     }
1878
1879     stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
1880     if (GIMME != G_ARRAY) {
1881         EXTEND(SP, 1);
1882         if (!stash_hek)
1883             PUSHs(&PL_sv_undef);
1884         else {
1885             dTARGET;
1886             sv_sethek(TARG, stash_hek);
1887             PUSHs(TARG);
1888         }
1889         RETURN;
1890     }
1891
1892     EXTEND(SP, 11);
1893
1894     if (!stash_hek)
1895         PUSHs(&PL_sv_undef);
1896     else {
1897         dTARGET;
1898         sv_sethek(TARG, stash_hek);
1899         PUSHTARG;
1900     }
1901     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1902     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1903     if (!has_arg)
1904         RETURN;
1905     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1906         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1907         /* So is ccstack[dbcxix]. */
1908         if (isGV(cvgv)) {
1909             SV * const sv = newSV(0);
1910             gv_efullname3(sv, cvgv, NULL);
1911             mPUSHs(sv);
1912             PUSHs(boolSV(CxHASARGS(cx)));
1913         }
1914         else {
1915             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1916             PUSHs(boolSV(CxHASARGS(cx)));
1917         }
1918     }
1919     else {
1920         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1921         mPUSHi(0);
1922     }
1923     gimme = (I32)cx->blk_gimme;
1924     if (gimme == G_VOID)
1925         PUSHs(&PL_sv_undef);
1926     else
1927         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1928     if (CxTYPE(cx) == CXt_EVAL) {
1929         /* eval STRING */
1930         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1931             PUSHs(cx->blk_eval.cur_text);
1932             PUSHs(&PL_sv_no);
1933         }
1934         /* require */
1935         else if (cx->blk_eval.old_namesv) {
1936             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1937             PUSHs(&PL_sv_yes);
1938         }
1939         /* eval BLOCK (try blocks have old_namesv == 0) */
1940         else {
1941             PUSHs(&PL_sv_undef);
1942             PUSHs(&PL_sv_undef);
1943         }
1944     }
1945     else {
1946         PUSHs(&PL_sv_undef);
1947         PUSHs(&PL_sv_undef);
1948     }
1949     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1950         && CopSTASH_eq(PL_curcop, PL_debstash))
1951     {
1952         AV * const ary = cx->blk_sub.argarray;
1953         const int off = AvARRAY(ary) - AvALLOC(ary);
1954
1955         Perl_init_dbargs(aTHX);
1956
1957         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1958             av_extend(PL_dbargs, AvFILLp(ary) + off);
1959         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1960         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1961     }
1962     /* XXX only hints propagated via op_private are currently
1963      * visible (others are not easily accessible, since they
1964      * use the global PL_hints) */
1965     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1966     {
1967         SV * mask ;
1968         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1969
1970         if  (old_warnings == pWARN_NONE ||
1971                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1972             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1973         else if (old_warnings == pWARN_ALL ||
1974                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1975             /* Get the bit mask for $warnings::Bits{all}, because
1976              * it could have been extended by warnings::register */
1977             SV **bits_all;
1978             HV * const bits = get_hv("warnings::Bits", 0);
1979             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1980                 mask = newSVsv(*bits_all);
1981             }
1982             else {
1983                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1984             }
1985         }
1986         else
1987             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1988         mPUSHs(mask);
1989     }
1990
1991     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1992           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1993           : &PL_sv_undef);
1994     RETURN;
1995 }
1996
1997 PP(pp_reset)
1998 {
1999     dVAR;
2000     dSP;
2001     const char * const tmps =
2002         (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
2003     sv_reset(tmps, CopSTASH(PL_curcop));
2004     PUSHs(&PL_sv_yes);
2005     RETURN;
2006 }
2007
2008 /* like pp_nextstate, but used instead when the debugger is active */
2009
2010 PP(pp_dbstate)
2011 {
2012     dVAR;
2013     PL_curcop = (COP*)PL_op;
2014     TAINT_NOT;          /* Each statement is presumed innocent */
2015     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2016     FREETMPS;
2017
2018     PERL_ASYNC_CHECK();
2019
2020     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2021             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2022     {
2023         dSP;
2024         register PERL_CONTEXT *cx;
2025         const I32 gimme = G_ARRAY;
2026         U8 hasargs;
2027         GV * const gv = PL_DBgv;
2028         register CV * const cv = GvCV(gv);
2029
2030         if (!cv)
2031             DIE(aTHX_ "No DB::DB routine defined");
2032
2033         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2034             /* don't do recursive DB::DB call */
2035             return NORMAL;
2036
2037         ENTER;
2038         SAVETMPS;
2039
2040         SAVEI32(PL_debug);
2041         SAVESTACK_POS();
2042         PL_debug = 0;
2043         hasargs = 0;
2044         SPAGAIN;
2045
2046         if (CvISXSUB(cv)) {
2047             CvDEPTH(cv)++;
2048             PUSHMARK(SP);
2049             (void)(*CvXSUB(cv))(aTHX_ cv);
2050             CvDEPTH(cv)--;
2051             FREETMPS;
2052             LEAVE;
2053             return NORMAL;
2054         }
2055         else {
2056             PUSHBLOCK(cx, CXt_SUB, SP);
2057             PUSHSUB_DB(cx);
2058             cx->blk_sub.retop = PL_op->op_next;
2059             CvDEPTH(cv)++;
2060             SAVECOMPPAD();
2061             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2062             RETURNOP(CvSTART(cv));
2063         }
2064     }
2065     else
2066         return NORMAL;
2067 }
2068
2069 STATIC SV **
2070 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2071 {
2072     bool padtmp = 0;
2073     PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2074
2075     if (flags & SVs_PADTMP) {
2076         flags &= ~SVs_PADTMP;
2077         padtmp = 1;
2078     }
2079     if (gimme == G_SCALAR) {
2080         if (MARK < SP)
2081             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2082                             ? *SP : sv_mortalcopy(*SP);
2083         else {
2084             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2085             MARK = newsp;
2086             MEXTEND(MARK, 1);
2087             *++MARK = &PL_sv_undef;
2088             return MARK;
2089         }
2090     }
2091     else if (gimme == G_ARRAY) {
2092         /* in case LEAVE wipes old return values */
2093         while (++MARK <= SP) {
2094             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2095                 *++newsp = *MARK;
2096             else {
2097                 *++newsp = sv_mortalcopy(*MARK);
2098                 TAINT_NOT;      /* Each item is independent */
2099             }
2100         }
2101         /* When this function was called with MARK == newsp, we reach this
2102          * point with SP == newsp. */
2103     }
2104
2105     return newsp;
2106 }
2107
2108 PP(pp_enter)
2109 {
2110     dVAR; dSP;
2111     register PERL_CONTEXT *cx;
2112     I32 gimme = GIMME_V;
2113
2114     ENTER_with_name("block");
2115
2116     SAVETMPS;
2117     PUSHBLOCK(cx, CXt_BLOCK, SP);
2118
2119     RETURN;
2120 }
2121
2122 PP(pp_leave)
2123 {
2124     dVAR; dSP;
2125     register PERL_CONTEXT *cx;
2126     SV **newsp;
2127     PMOP *newpm;
2128     I32 gimme;
2129
2130     if (PL_op->op_flags & OPf_SPECIAL) {
2131         cx = &cxstack[cxstack_ix];
2132         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2133     }
2134
2135     POPBLOCK(cx,newpm);
2136
2137     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2138
2139     TAINT_NOT;
2140     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2141     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2142
2143     LEAVE_with_name("block");
2144
2145     RETURN;
2146 }
2147
2148 PP(pp_enteriter)
2149 {
2150     dVAR; dSP; dMARK;
2151     register PERL_CONTEXT *cx;
2152     const I32 gimme = GIMME_V;
2153     void *itervar; /* location of the iteration variable */
2154     U8 cxtype = CXt_LOOP_FOR;
2155
2156     ENTER_with_name("loop1");
2157     SAVETMPS;
2158
2159     if (PL_op->op_targ) {                        /* "my" variable */
2160         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2161             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2162             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2163                     SVs_PADSTALE, SVs_PADSTALE);
2164         }
2165         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2166 #ifdef USE_ITHREADS
2167         itervar = PL_comppad;
2168 #else
2169         itervar = &PAD_SVl(PL_op->op_targ);
2170 #endif
2171     }
2172     else {                                      /* symbol table variable */
2173         GV * const gv = MUTABLE_GV(POPs);
2174         SV** svp = &GvSV(gv);
2175         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2176         *svp = newSV(0);
2177         itervar = (void *)gv;
2178     }
2179
2180     if (PL_op->op_private & OPpITER_DEF)
2181         cxtype |= CXp_FOR_DEF;
2182
2183     ENTER_with_name("loop2");
2184
2185     PUSHBLOCK(cx, cxtype, SP);
2186     PUSHLOOP_FOR(cx, itervar, MARK);
2187     if (PL_op->op_flags & OPf_STACKED) {
2188         SV *maybe_ary = POPs;
2189         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2190             dPOPss;
2191             SV * const right = maybe_ary;
2192             SvGETMAGIC(sv);
2193             SvGETMAGIC(right);
2194             if (RANGE_IS_NUMERIC(sv,right)) {
2195                 cx->cx_type &= ~CXTYPEMASK;
2196                 cx->cx_type |= CXt_LOOP_LAZYIV;
2197                 /* Make sure that no-one re-orders cop.h and breaks our
2198                    assumptions */
2199                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2200 #ifdef NV_PRESERVES_UV
2201                 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2202                                   (SvNV_nomg(sv) > (NV)IV_MAX)))
2203                         ||
2204                     (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2205                                      (SvNV_nomg(right) < (NV)IV_MIN))))
2206 #else
2207                 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2208                                   ||
2209                                   ((SvNV_nomg(sv) > 0) &&
2210                                         ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2211                                          (SvNV_nomg(sv) > (NV)UV_MAX)))))
2212                         ||
2213                     (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2214                                      ||
2215                                      ((SvNV_nomg(right) > 0) &&
2216                                         ((SvUV_nomg(right) > (UV)IV_MAX) ||
2217                                          (SvNV_nomg(right) > (NV)UV_MAX))
2218                                      ))))
2219 #endif
2220                     DIE(aTHX_ "Range iterator outside integer range");
2221                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2222                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2223 #ifdef DEBUGGING
2224                 /* for correct -Dstv display */
2225                 cx->blk_oldsp = sp - PL_stack_base;
2226 #endif
2227             }
2228             else {
2229                 cx->cx_type &= ~CXTYPEMASK;
2230                 cx->cx_type |= CXt_LOOP_LAZYSV;
2231                 /* Make sure that no-one re-orders cop.h and breaks our
2232                    assumptions */
2233                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2234                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2235                 cx->blk_loop.state_u.lazysv.end = right;
2236                 SvREFCNT_inc(right);
2237                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2238                 /* This will do the upgrade to SVt_PV, and warn if the value
2239                    is uninitialised.  */
2240                 (void) SvPV_nolen_const(right);
2241                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2242                    to replace !SvOK() with a pointer to "".  */
2243                 if (!SvOK(right)) {
2244                     SvREFCNT_dec(right);
2245                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2246                 }
2247             }
2248         }
2249         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2250             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2251             SvREFCNT_inc(maybe_ary);
2252             cx->blk_loop.state_u.ary.ix =
2253                 (PL_op->op_private & OPpITER_REVERSED) ?
2254                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2255                 -1;
2256         }
2257     }
2258     else { /* iterating over items on the stack */
2259         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2260         if (PL_op->op_private & OPpITER_REVERSED) {
2261             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2262         }
2263         else {
2264             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2265         }
2266     }
2267
2268     RETURN;
2269 }
2270
2271 PP(pp_enterloop)
2272 {
2273     dVAR; dSP;
2274     register PERL_CONTEXT *cx;
2275     const I32 gimme = GIMME_V;
2276
2277     ENTER_with_name("loop1");
2278     SAVETMPS;
2279     ENTER_with_name("loop2");
2280
2281     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2282     PUSHLOOP_PLAIN(cx, SP);
2283
2284     RETURN;
2285 }
2286
2287 PP(pp_leaveloop)
2288 {
2289     dVAR; dSP;
2290     register PERL_CONTEXT *cx;
2291     I32 gimme;
2292     SV **newsp;
2293     PMOP *newpm;
2294     SV **mark;
2295
2296     POPBLOCK(cx,newpm);
2297     assert(CxTYPE_is_LOOP(cx));
2298     mark = newsp;
2299     newsp = PL_stack_base + cx->blk_loop.resetsp;
2300
2301     TAINT_NOT;
2302     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2303     PUTBACK;
2304
2305     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2306     PL_curpm = newpm;   /* ... and pop $1 et al */
2307
2308     LEAVE_with_name("loop2");
2309     LEAVE_with_name("loop1");
2310
2311     return NORMAL;
2312 }
2313
2314 STATIC void
2315 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2316                        PERL_CONTEXT *cx, PMOP *newpm)
2317 {
2318     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2319     if (gimme == G_SCALAR) {
2320         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2321             SV *sv;
2322             const char *what = NULL;
2323             if (MARK < SP) {
2324                 assert(MARK+1 == SP);
2325                 if ((SvPADTMP(TOPs) ||
2326                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2327                        == SVf_READONLY
2328                     ) &&
2329                     !SvSMAGICAL(TOPs)) {
2330                     what =
2331                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2332                         : "a readonly value" : "a temporary";
2333                 }
2334                 else goto copy_sv;
2335             }
2336             else {
2337                 /* sub:lvalue{} will take us here. */
2338                 what = "undef";
2339             }
2340             LEAVE;
2341             cxstack_ix--;
2342             POPSUB(cx,sv);
2343             PL_curpm = newpm;
2344             LEAVESUB(sv);
2345             Perl_croak(aTHX_
2346                       "Can't return %s from lvalue subroutine", what
2347             );
2348         }
2349         if (MARK < SP) {
2350               copy_sv:
2351                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2352                         *++newsp = SvREFCNT_inc(*SP);
2353                         FREETMPS;
2354                         sv_2mortal(*newsp);
2355                 }
2356                 else
2357                     *++newsp =
2358                         !SvTEMP(*SP)
2359                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2360                           : *SP;
2361         }
2362         else {
2363             EXTEND(newsp,1);
2364             *++newsp = &PL_sv_undef;
2365         }
2366         if (CxLVAL(cx) & OPpDEREF) {
2367             SvGETMAGIC(TOPs);
2368             if (!SvOK(TOPs)) {
2369                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2370             }
2371         }
2372     }
2373     else if (gimme == G_ARRAY) {
2374         assert (!(CxLVAL(cx) & OPpDEREF));
2375         if (ref || !CxLVAL(cx))
2376             while (++MARK <= SP)
2377                 *++newsp =
2378                      SvTEMP(*MARK)
2379                        ? *MARK
2380                        : ref && SvFLAGS(*MARK) & SVs_PADTMP
2381                            ? sv_mortalcopy(*MARK)
2382                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2383         else while (++MARK <= SP) {
2384             if (*MARK != &PL_sv_undef
2385                     && (SvPADTMP(*MARK)
2386                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2387                              == SVf_READONLY
2388                        )
2389             ) {
2390                     SV *sv;
2391                     /* Might be flattened array after $#array =  */
2392                     PUTBACK;
2393                     LEAVE;
2394                     cxstack_ix--;
2395                     POPSUB(cx,sv);
2396                     PL_curpm = newpm;
2397                     LEAVESUB(sv);
2398                     Perl_croak(aTHX_
2399                         "Can't return a %s from lvalue subroutine",
2400                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2401             }
2402             else
2403                 *++newsp =
2404                     SvTEMP(*MARK)
2405                        ? *MARK
2406                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2407         }
2408     }
2409     PL_stack_sp = newsp;
2410 }
2411
2412 PP(pp_return)
2413 {
2414     dVAR; dSP; dMARK;
2415     register PERL_CONTEXT *cx;
2416     bool popsub2 = FALSE;
2417     bool clear_errsv = FALSE;
2418     bool lval = FALSE;
2419     I32 gimme;
2420     SV **newsp;
2421     PMOP *newpm;
2422     I32 optype = 0;
2423     SV *namesv;
2424     SV *sv;
2425     OP *retop = NULL;
2426
2427     const I32 cxix = dopoptosub(cxstack_ix);
2428
2429     if (cxix < 0) {
2430         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2431                                      * sort block, which is a CXt_NULL
2432                                      * not a CXt_SUB */
2433             dounwind(0);
2434             PL_stack_base[1] = *PL_stack_sp;
2435             PL_stack_sp = PL_stack_base + 1;
2436             return 0;
2437         }
2438         else
2439             DIE(aTHX_ "Can't return outside a subroutine");
2440     }
2441     if (cxix < cxstack_ix)
2442         dounwind(cxix);
2443
2444     if (CxMULTICALL(&cxstack[cxix])) {
2445         gimme = cxstack[cxix].blk_gimme;
2446         if (gimme == G_VOID)
2447             PL_stack_sp = PL_stack_base;
2448         else if (gimme == G_SCALAR) {
2449             PL_stack_base[1] = *PL_stack_sp;
2450             PL_stack_sp = PL_stack_base + 1;
2451         }
2452         return 0;
2453     }
2454
2455     POPBLOCK(cx,newpm);
2456     switch (CxTYPE(cx)) {
2457     case CXt_SUB:
2458         popsub2 = TRUE;
2459         lval = !!CvLVALUE(cx->blk_sub.cv);
2460         retop = cx->blk_sub.retop;
2461         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2462         break;
2463     case CXt_EVAL:
2464         if (!(PL_in_eval & EVAL_KEEPERR))
2465             clear_errsv = TRUE;
2466         POPEVAL(cx);
2467         namesv = cx->blk_eval.old_namesv;
2468         retop = cx->blk_eval.retop;
2469         if (CxTRYBLOCK(cx))
2470             break;
2471         if (optype == OP_REQUIRE &&
2472             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2473         {
2474             /* Unassume the success we assumed earlier. */
2475             (void)hv_delete(GvHVn(PL_incgv),
2476                             SvPVX_const(namesv),
2477                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2478                             G_DISCARD);
2479             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2480         }
2481         break;
2482     case CXt_FORMAT:
2483         POPFORMAT(cx);
2484         retop = cx->blk_sub.retop;
2485         break;
2486     default:
2487         DIE(aTHX_ "panic: return");
2488     }
2489
2490     TAINT_NOT;
2491     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2492     else {
2493       if (gimme == G_SCALAR) {
2494         if (MARK < SP) {
2495             if (popsub2) {
2496                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2497                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2498                         *++newsp = SvREFCNT_inc(*SP);
2499                         FREETMPS;
2500                         sv_2mortal(*newsp);
2501                     }
2502                     else {
2503                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2504                         FREETMPS;
2505                         *++newsp = sv_mortalcopy(sv);
2506                         SvREFCNT_dec(sv);
2507                     }
2508                 }
2509                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
2510                     *++newsp = *SP;
2511                 }
2512                 else
2513                     *++newsp = sv_mortalcopy(*SP);
2514             }
2515             else
2516                 *++newsp = sv_mortalcopy(*SP);
2517         }
2518         else
2519             *++newsp = &PL_sv_undef;
2520       }
2521       else if (gimme == G_ARRAY) {
2522         while (++MARK <= SP) {
2523             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2524                         ? *MARK : sv_mortalcopy(*MARK);
2525             TAINT_NOT;          /* Each item is independent */
2526         }
2527       }
2528       PL_stack_sp = newsp;
2529     }
2530
2531     LEAVE;
2532     /* Stack values are safe: */
2533     if (popsub2) {
2534         cxstack_ix--;
2535         POPSUB(cx,sv);  /* release CV and @_ ... */
2536     }
2537     else
2538         sv = NULL;
2539     PL_curpm = newpm;   /* ... and pop $1 et al */
2540
2541     LEAVESUB(sv);
2542     if (clear_errsv) {
2543         CLEAR_ERRSV();
2544     }
2545     return retop;
2546 }
2547
2548 /* This duplicates parts of pp_leavesub, so that it can share code with
2549  * pp_return */
2550 PP(pp_leavesublv)
2551 {
2552     dVAR; dSP;
2553     SV **newsp;
2554     PMOP *newpm;
2555     I32 gimme;
2556     register PERL_CONTEXT *cx;
2557     SV *sv;
2558
2559     if (CxMULTICALL(&cxstack[cxstack_ix]))
2560         return 0;
2561
2562     POPBLOCK(cx,newpm);
2563     cxstack_ix++; /* temporarily protect top context */
2564
2565     TAINT_NOT;
2566
2567     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2568
2569     LEAVE;
2570     cxstack_ix--;
2571     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2572     PL_curpm = newpm;   /* ... and pop $1 et al */
2573
2574     LEAVESUB(sv);
2575     return cx->blk_sub.retop;
2576 }
2577
2578 PP(pp_last)
2579 {
2580     dVAR; dSP;
2581     I32 cxix;
2582     register PERL_CONTEXT *cx;
2583     I32 pop2 = 0;
2584     I32 gimme;
2585     I32 optype;
2586     OP *nextop = NULL;
2587     SV **newsp;
2588     PMOP *newpm;
2589     SV **mark;
2590     SV *sv = NULL;
2591
2592
2593     if (PL_op->op_flags & OPf_SPECIAL) {
2594         cxix = dopoptoloop(cxstack_ix);
2595         if (cxix < 0)
2596             DIE(aTHX_ "Can't \"last\" outside a loop block");
2597     }
2598     else {
2599         cxix = dopoptolabel(cPVOP->op_pv);
2600         if (cxix < 0)
2601             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2602     }
2603     if (cxix < cxstack_ix)
2604         dounwind(cxix);
2605
2606     POPBLOCK(cx,newpm);
2607     cxstack_ix++; /* temporarily protect top context */
2608     mark = newsp;
2609     switch (CxTYPE(cx)) {
2610     case CXt_LOOP_LAZYIV:
2611     case CXt_LOOP_LAZYSV:
2612     case CXt_LOOP_FOR:
2613     case CXt_LOOP_PLAIN:
2614         pop2 = CxTYPE(cx);
2615         newsp = PL_stack_base + cx->blk_loop.resetsp;
2616         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2617         break;
2618     case CXt_SUB:
2619         pop2 = CXt_SUB;
2620         nextop = cx->blk_sub.retop;
2621         break;
2622     case CXt_EVAL:
2623         POPEVAL(cx);
2624         nextop = cx->blk_eval.retop;
2625         break;
2626     case CXt_FORMAT:
2627         POPFORMAT(cx);
2628         nextop = cx->blk_sub.retop;
2629         break;
2630     default:
2631         DIE(aTHX_ "panic: last");
2632     }
2633
2634     TAINT_NOT;
2635     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2636                                 pop2 == CXt_SUB ? SVs_TEMP : 0);
2637     PUTBACK;
2638
2639     LEAVE;
2640     cxstack_ix--;
2641     /* Stack values are safe: */
2642     switch (pop2) {
2643     case CXt_LOOP_LAZYIV:
2644     case CXt_LOOP_PLAIN:
2645     case CXt_LOOP_LAZYSV:
2646     case CXt_LOOP_FOR:
2647         POPLOOP(cx);    /* release loop vars ... */
2648         LEAVE;
2649         break;
2650     case CXt_SUB:
2651         POPSUB(cx,sv);  /* release CV and @_ ... */
2652         break;
2653     }
2654     PL_curpm = newpm;   /* ... and pop $1 et al */
2655
2656     LEAVESUB(sv);
2657     PERL_UNUSED_VAR(optype);
2658     PERL_UNUSED_VAR(gimme);
2659     return nextop;
2660 }
2661
2662 PP(pp_next)
2663 {
2664     dVAR;
2665     I32 cxix;
2666     register PERL_CONTEXT *cx;
2667     I32 inner;
2668
2669     if (PL_op->op_flags & OPf_SPECIAL) {
2670         cxix = dopoptoloop(cxstack_ix);
2671         if (cxix < 0)
2672             DIE(aTHX_ "Can't \"next\" outside a loop block");
2673     }
2674     else {
2675         cxix = dopoptolabel(cPVOP->op_pv);
2676         if (cxix < 0)
2677             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2678     }
2679     if (cxix < cxstack_ix)
2680         dounwind(cxix);
2681
2682     /* clear off anything above the scope we're re-entering, but
2683      * save the rest until after a possible continue block */
2684     inner = PL_scopestack_ix;
2685     TOPBLOCK(cx);
2686     if (PL_scopestack_ix < inner)
2687         leave_scope(PL_scopestack[PL_scopestack_ix]);
2688     PL_curcop = cx->blk_oldcop;
2689     return (cx)->blk_loop.my_op->op_nextop;
2690 }
2691
2692 PP(pp_redo)
2693 {
2694     dVAR;
2695     I32 cxix;
2696     register PERL_CONTEXT *cx;
2697     I32 oldsave;
2698     OP* redo_op;
2699
2700     if (PL_op->op_flags & OPf_SPECIAL) {
2701         cxix = dopoptoloop(cxstack_ix);
2702         if (cxix < 0)
2703             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2704     }
2705     else {
2706         cxix = dopoptolabel(cPVOP->op_pv);
2707         if (cxix < 0)
2708             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2709     }
2710     if (cxix < cxstack_ix)
2711         dounwind(cxix);
2712
2713     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2714     if (redo_op->op_type == OP_ENTER) {
2715         /* pop one less context to avoid $x being freed in while (my $x..) */
2716         cxstack_ix++;
2717         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2718         redo_op = redo_op->op_next;
2719     }
2720
2721     TOPBLOCK(cx);
2722     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2723     LEAVE_SCOPE(oldsave);
2724     FREETMPS;
2725     PL_curcop = cx->blk_oldcop;
2726     return redo_op;
2727 }
2728
2729 STATIC OP *
2730 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2731 {
2732     dVAR;
2733     OP **ops = opstack;
2734     static const char too_deep[] = "Target of goto is too deeply nested";
2735
2736     PERL_ARGS_ASSERT_DOFINDLABEL;
2737
2738     if (ops >= oplimit)
2739         Perl_croak(aTHX_ too_deep);
2740     if (o->op_type == OP_LEAVE ||
2741         o->op_type == OP_SCOPE ||
2742         o->op_type == OP_LEAVELOOP ||
2743         o->op_type == OP_LEAVESUB ||
2744         o->op_type == OP_LEAVETRY)
2745     {
2746         *ops++ = cUNOPo->op_first;
2747         if (ops >= oplimit)
2748             Perl_croak(aTHX_ too_deep);
2749     }
2750     *ops = 0;
2751     if (o->op_flags & OPf_KIDS) {
2752         OP *kid;
2753         /* First try all the kids at this level, since that's likeliest. */
2754         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2755             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2756                 const char *kid_label = CopLABEL(kCOP);
2757                 if (kid_label && strEQ(kid_label, label))
2758                     return kid;
2759             }
2760         }
2761         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2762             if (kid == PL_lastgotoprobe)
2763                 continue;
2764             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2765                 if (ops == opstack)
2766                     *ops++ = kid;
2767                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2768                          ops[-1]->op_type == OP_DBSTATE)
2769                     ops[-1] = kid;
2770                 else
2771                     *ops++ = kid;
2772             }
2773             if ((o = dofindlabel(kid, label, ops, oplimit)))
2774                 return o;
2775         }
2776     }
2777     *ops = 0;
2778     return 0;
2779 }
2780
2781 PP(pp_goto)
2782 {
2783     dVAR; dSP;
2784     OP *retop = NULL;
2785     I32 ix;
2786     register PERL_CONTEXT *cx;
2787 #define GOTO_DEPTH 64
2788     OP *enterops[GOTO_DEPTH];
2789     const char *label = NULL;
2790     const bool do_dump = (PL_op->op_type == OP_DUMP);
2791     static const char must_have_label[] = "goto must have label";
2792
2793     if (PL_op->op_flags & OPf_STACKED) {
2794         SV * const sv = POPs;
2795
2796         /* This egregious kludge implements goto &subroutine */
2797         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2798             I32 cxix;
2799             register PERL_CONTEXT *cx;
2800             CV *cv = MUTABLE_CV(SvRV(sv));
2801             SV** mark;
2802             I32 items = 0;
2803             I32 oldsave;
2804             bool reified = 0;
2805
2806         retry:
2807             if (!CvROOT(cv) && !CvXSUB(cv)) {
2808                 const GV * const gv = CvGV(cv);
2809                 if (gv) {
2810                     GV *autogv;
2811                     SV *tmpstr;
2812                     /* autoloaded stub? */
2813                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2814                         goto retry;
2815                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2816                                           GvNAMELEN(gv),
2817                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2818                     if (autogv && (cv = GvCV(autogv)))
2819                         goto retry;
2820                     tmpstr = sv_newmortal();
2821                     gv_efullname3(tmpstr, gv, NULL);
2822                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2823                 }
2824                 DIE(aTHX_ "Goto undefined subroutine");
2825             }
2826
2827             /* First do some returnish stuff. */
2828             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2829             FREETMPS;
2830             cxix = dopoptosub(cxstack_ix);
2831             if (cxix < 0)
2832                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2833             if (cxix < cxstack_ix)
2834                 dounwind(cxix);
2835             TOPBLOCK(cx);
2836             SPAGAIN;
2837             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2838             if (CxTYPE(cx) == CXt_EVAL) {
2839                 if (CxREALEVAL(cx))
2840                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2841                 else
2842                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2843             }
2844             else if (CxMULTICALL(cx))
2845                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2846             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2847                 /* put @_ back onto stack */
2848                 AV* av = cx->blk_sub.argarray;
2849
2850                 items = AvFILLp(av) + 1;
2851                 EXTEND(SP, items+1); /* @_ could have been extended. */
2852                 Copy(AvARRAY(av), SP + 1, items, SV*);
2853                 SvREFCNT_dec(GvAV(PL_defgv));
2854                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2855                 CLEAR_ARGARRAY(av);
2856                 /* abandon @_ if it got reified */
2857                 if (AvREAL(av)) {
2858                     reified = 1;
2859                     SvREFCNT_dec(av);
2860                     av = newAV();
2861                     av_extend(av, items-1);
2862                     AvREIFY_only(av);
2863                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2864                 }
2865             }
2866             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2867                 AV* const av = GvAV(PL_defgv);
2868                 items = AvFILLp(av) + 1;
2869                 EXTEND(SP, items+1); /* @_ could have been extended. */
2870                 Copy(AvARRAY(av), SP + 1, items, SV*);
2871             }
2872             mark = SP;
2873             SP += items;
2874             if (CxTYPE(cx) == CXt_SUB &&
2875                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2876                 SvREFCNT_dec(cx->blk_sub.cv);
2877             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2878             LEAVE_SCOPE(oldsave);
2879
2880             /* A destructor called during LEAVE_SCOPE could have undefined
2881              * our precious cv.  See bug #99850. */
2882             if (!CvROOT(cv) && !CvXSUB(cv)) {
2883                 const GV * const gv = CvGV(cv);
2884                 if (gv) {
2885                     SV * const tmpstr = sv_newmortal();
2886                     gv_efullname3(tmpstr, gv, NULL);
2887                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2888                                SVfARG(tmpstr));
2889                 }
2890                 DIE(aTHX_ "Goto undefined subroutine");
2891             }
2892
2893             /* Now do some callish stuff. */
2894             SAVETMPS;
2895             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2896             if (CvISXSUB(cv)) {
2897                 OP* const retop = cx->blk_sub.retop;
2898                 SV **newsp PERL_UNUSED_DECL;
2899                 I32 gimme PERL_UNUSED_DECL;
2900                 if (reified) {
2901                     I32 index;
2902                     for (index=0; index<items; index++)
2903                         sv_2mortal(SP[-index]);
2904                 }
2905
2906                 /* XS subs don't have a CxSUB, so pop it */
2907                 POPBLOCK(cx, PL_curpm);
2908                 /* Push a mark for the start of arglist */
2909                 PUSHMARK(mark);
2910                 PUTBACK;
2911                 (void)(*CvXSUB(cv))(aTHX_ cv);
2912                 LEAVE;
2913                 return retop;
2914             }
2915             else {
2916                 AV* const padlist = CvPADLIST(cv);
2917                 if (CxTYPE(cx) == CXt_EVAL) {
2918                     PL_in_eval = CxOLD_IN_EVAL(cx);
2919                     PL_eval_root = cx->blk_eval.old_eval_root;
2920                     cx->cx_type = CXt_SUB;
2921                 }
2922                 cx->blk_sub.cv = cv;
2923                 cx->blk_sub.olddepth = CvDEPTH(cv);
2924
2925                 CvDEPTH(cv)++;
2926                 if (CvDEPTH(cv) < 2)
2927                     SvREFCNT_inc_simple_void_NN(cv);
2928                 else {
2929                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2930                         sub_crush_depth(cv);
2931                     pad_push(padlist, CvDEPTH(cv));
2932                 }
2933                 PL_curcop = cx->blk_oldcop;
2934                 SAVECOMPPAD();
2935                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2936                 if (CxHASARGS(cx))
2937                 {
2938                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2939
2940                     cx->blk_sub.savearray = GvAV(PL_defgv);
2941                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2942                     CX_CURPAD_SAVE(cx->blk_sub);
2943                     cx->blk_sub.argarray = av;
2944
2945                     if (items >= AvMAX(av) + 1) {
2946                         SV **ary = AvALLOC(av);
2947                         if (AvARRAY(av) != ary) {
2948                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2949                             AvARRAY(av) = ary;
2950                         }
2951                         if (items >= AvMAX(av) + 1) {
2952                             AvMAX(av) = items - 1;
2953                             Renew(ary,items+1,SV*);
2954                             AvALLOC(av) = ary;
2955                             AvARRAY(av) = ary;
2956                         }
2957                     }
2958                     ++mark;
2959                     Copy(mark,AvARRAY(av),items,SV*);
2960                     AvFILLp(av) = items - 1;
2961                     assert(!AvREAL(av));
2962                     if (reified) {
2963                         /* transfer 'ownership' of refcnts to new @_ */
2964                         AvREAL_on(av);
2965                         AvREIFY_off(av);
2966                     }
2967                     while (items--) {
2968                         if (*mark)
2969                             SvTEMP_off(*mark);
2970                         mark++;
2971                     }
2972                 }
2973                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2974                     Perl_get_db_sub(aTHX_ NULL, cv);
2975                     if (PERLDB_GOTO) {
2976                         CV * const gotocv = get_cvs("DB::goto", 0);
2977                         if (gotocv) {
2978                             PUSHMARK( PL_stack_sp );
2979                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2980                             PL_stack_sp--;
2981                         }
2982                     }
2983                 }
2984                 RETURNOP(CvSTART(cv));
2985             }
2986         }
2987         else {
2988             label = SvPV_nolen_const(sv);
2989             if (!(do_dump || *label))
2990                 DIE(aTHX_ must_have_label);
2991         }
2992     }
2993     else if (PL_op->op_flags & OPf_SPECIAL) {
2994         if (! do_dump)
2995             DIE(aTHX_ must_have_label);
2996     }
2997     else
2998         label = cPVOP->op_pv;
2999
3000     PERL_ASYNC_CHECK();
3001
3002     if (label && *label) {
3003         OP *gotoprobe = NULL;
3004         bool leaving_eval = FALSE;
3005         bool in_block = FALSE;
3006         PERL_CONTEXT *last_eval_cx = NULL;
3007
3008         /* find label */
3009
3010         PL_lastgotoprobe = NULL;
3011         *enterops = 0;
3012         for (ix = cxstack_ix; ix >= 0; ix--) {
3013             cx = &cxstack[ix];
3014             switch (CxTYPE(cx)) {
3015             case CXt_EVAL:
3016                 leaving_eval = TRUE;
3017                 if (!CxTRYBLOCK(cx)) {
3018                     gotoprobe = (last_eval_cx ?
3019                                 last_eval_cx->blk_eval.old_eval_root :
3020                                 PL_eval_root);
3021                     last_eval_cx = cx;
3022                     break;
3023                 }
3024                 /* else fall through */
3025             case CXt_LOOP_LAZYIV:
3026             case CXt_LOOP_LAZYSV:
3027             case CXt_LOOP_FOR:
3028             case CXt_LOOP_PLAIN:
3029             case CXt_GIVEN:
3030             case CXt_WHEN:
3031                 gotoprobe = cx->blk_oldcop->op_sibling;
3032                 break;
3033             case CXt_SUBST:
3034                 continue;
3035             case CXt_BLOCK:
3036                 if (ix) {
3037                     gotoprobe = cx->blk_oldcop->op_sibling;
3038                     in_block = TRUE;
3039                 } else
3040                     gotoprobe = PL_main_root;
3041                 break;
3042             case CXt_SUB:
3043                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3044                     gotoprobe = CvROOT(cx->blk_sub.cv);
3045                     break;
3046                 }
3047                 /* FALL THROUGH */
3048             case CXt_FORMAT:
3049             case CXt_NULL:
3050                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3051             default:
3052                 if (ix)
3053                     DIE(aTHX_ "panic: goto");
3054                 gotoprobe = PL_main_root;
3055                 break;
3056             }
3057             if (gotoprobe) {
3058                 retop = dofindlabel(gotoprobe, label,
3059                                     enterops, enterops + GOTO_DEPTH);
3060                 if (retop)
3061                     break;
3062                 if (gotoprobe->op_sibling &&
3063                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3064                         gotoprobe->op_sibling->op_sibling) {
3065                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3066                                         label, enterops, enterops + GOTO_DEPTH);
3067                     if (retop)
3068                         break;
3069                 }
3070             }
3071             PL_lastgotoprobe = gotoprobe;
3072         }
3073         if (!retop)
3074             DIE(aTHX_ "Can't find label %s", label);
3075
3076         /* if we're leaving an eval, check before we pop any frames
3077            that we're not going to punt, otherwise the error
3078            won't be caught */
3079
3080         if (leaving_eval && *enterops && enterops[1]) {
3081             I32 i;
3082             for (i = 1; enterops[i]; i++)
3083                 if (enterops[i]->op_type == OP_ENTERITER)
3084                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3085         }
3086
3087         if (*enterops && enterops[1]) {
3088             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3089             if (enterops[i])
3090                 deprecate("\"goto\" to jump into a construct");
3091         }
3092
3093         /* pop unwanted frames */
3094
3095         if (ix < cxstack_ix) {
3096             I32 oldsave;
3097
3098             if (ix < 0)
3099                 ix = 0;
3100             dounwind(ix);
3101             TOPBLOCK(cx);
3102             oldsave = PL_scopestack[PL_scopestack_ix];
3103             LEAVE_SCOPE(oldsave);
3104         }
3105
3106         /* push wanted frames */
3107
3108         if (*enterops && enterops[1]) {
3109             OP * const oldop = PL_op;
3110             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3111             for (; enterops[ix]; ix++) {
3112                 PL_op = enterops[ix];
3113                 /* Eventually we may want to stack the needed arguments
3114                  * for each op.  For now, we punt on the hard ones. */
3115                 if (PL_op->op_type == OP_ENTERITER)
3116                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3117                 PL_op->op_ppaddr(aTHX);
3118             }
3119             PL_op = oldop;
3120         }
3121     }
3122
3123     if (do_dump) {
3124 #ifdef VMS
3125         if (!retop) retop = PL_main_start;
3126 #endif
3127         PL_restartop = retop;
3128         PL_do_undump = TRUE;
3129
3130         my_unexec();
3131
3132         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3133         PL_do_undump = FALSE;
3134     }
3135
3136     RETURNOP(retop);
3137 }
3138
3139 PP(pp_exit)
3140 {
3141     dVAR;
3142     dSP;
3143     I32 anum;
3144
3145     if (MAXARG < 1)
3146         anum = 0;
3147     else if (!TOPs) {
3148         anum = 0; (void)POPs;
3149     }
3150     else {
3151         anum = SvIVx(POPs);
3152 #ifdef VMS
3153         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3154             anum = 0;
3155         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3156 #endif
3157     }
3158     PL_exit_flags |= PERL_EXIT_EXPECTED;
3159 #ifdef PERL_MAD
3160     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3161     if (anum || !(PL_minus_c && PL_madskills))
3162         my_exit(anum);
3163 #else
3164     my_exit(anum);
3165 #endif
3166     PUSHs(&PL_sv_undef);
3167     RETURN;
3168 }
3169
3170 /* Eval. */
3171
3172 STATIC void
3173 S_save_lines(pTHX_ AV *array, SV *sv)
3174 {
3175     const char *s = SvPVX_const(sv);
3176     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3177     I32 line = 1;
3178
3179     PERL_ARGS_ASSERT_SAVE_LINES;
3180
3181     while (s && s < send) {
3182         const char *t;
3183         SV * const tmpstr = newSV_type(SVt_PVMG);
3184
3185         t = (const char *)memchr(s, '\n', send - s);
3186         if (t)
3187             t++;
3188         else
3189             t = send;
3190
3191         sv_setpvn(tmpstr, s, t - s);
3192         av_store(array, line++, tmpstr);
3193         s = t;
3194     }
3195 }
3196
3197 /*
3198 =for apidoc docatch
3199
3200 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3201
3202 0 is used as continue inside eval,
3203
3204 3 is used for a die caught by an inner eval - continue inner loop
3205
3206 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3207 establish a local jmpenv to handle exception traps.
3208
3209 =cut
3210 */
3211 STATIC OP *
3212 S_docatch(pTHX_ OP *o)
3213 {
3214     dVAR;
3215     int ret;
3216     OP * const oldop = PL_op;
3217     dJMPENV;
3218
3219 #ifdef DEBUGGING
3220     assert(CATCH_GET == TRUE);
3221 #endif
3222     PL_op = o;
3223
3224     JMPENV_PUSH(ret);
3225     switch (ret) {
3226     case 0:
3227         assert(cxstack_ix >= 0);
3228         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3229         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3230  redo_body:
3231         CALLRUNOPS(aTHX);
3232         break;
3233     case 3:
3234         /* die caught by an inner eval - continue inner loop */
3235         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3236             PL_restartjmpenv = NULL;
3237             PL_op = PL_restartop;
3238             PL_restartop = 0;
3239             goto redo_body;
3240         }
3241         /* FALL THROUGH */
3242     default:
3243         JMPENV_POP;
3244         PL_op = oldop;
3245         JMPENV_JUMP(ret);
3246         /* NOTREACHED */
3247     }
3248     JMPENV_POP;
3249     PL_op = oldop;
3250     return NULL;
3251 }
3252
3253 /* James Bond: Do you expect me to talk?
3254    Auric Goldfinger: No, Mr. Bond. I expect you to die.
3255
3256    This code is an ugly hack, doesn't work with lexicals in subroutines that are
3257    called more than once, and is only used by regcomp.c, for (?{}) blocks.
3258
3259    Currently it is not used outside the core code. Best if it stays that way.
3260
3261    Hence it's now deprecated, and will be removed.
3262 */
3263 OP *
3264 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3265 /* sv Text to convert to OP tree. */
3266 /* startop op_free() this to undo. */
3267 /* code Short string id of the caller. */
3268 {
3269     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3270     return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3271 }
3272
3273 /* Don't use this. It will go away without warning once the regexp engine is
3274    refactored not to use it.  */
3275 OP *
3276 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3277                               PAD **padp)
3278 {
3279     dVAR; dSP;                          /* Make POPBLOCK work. */
3280     PERL_CONTEXT *cx;
3281     SV **newsp;
3282     I32 gimme = G_VOID;
3283     I32 optype;
3284     OP dummy;
3285     char tbuf[TYPE_DIGITS(long) + 12 + 10];
3286     char *tmpbuf = tbuf;
3287     char *safestr;
3288     int runtime;
3289     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3290     STRLEN len;
3291     bool need_catch;
3292
3293     PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3294
3295     ENTER_with_name("eval");
3296     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3297     SAVETMPS;
3298     /* switch to eval mode */
3299
3300     if (IN_PERL_COMPILETIME) {
3301         SAVECOPSTASH_FREE(&PL_compiling);
3302         CopSTASH_set(&PL_compiling, PL_curstash);
3303     }
3304     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3305         SV * const sv = sv_newmortal();
3306         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3307                        code, (unsigned long)++PL_evalseq,
3308                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3309         tmpbuf = SvPVX(sv);
3310         len = SvCUR(sv);
3311     }
3312     else
3313         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3314                           (unsigned long)++PL_evalseq);
3315     SAVECOPFILE_FREE(&PL_compiling);
3316     CopFILE_set(&PL_compiling, tmpbuf+2);
3317     SAVECOPLINE(&PL_compiling);
3318     CopLINE_set(&PL_compiling, 1);
3319     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3320        deleting the eval's FILEGV from the stash before gv_check() runs
3321        (i.e. before run-time proper). To work around the coredump that
3322        ensues, we always turn GvMULTI_on for any globals that were
3323        introduced within evals. See force_ident(). GSAR 96-10-12 */
3324     safestr = savepvn(tmpbuf, len);
3325     SAVEDELETE(PL_defstash, safestr, len);
3326     SAVEHINTS();
3327 #ifdef OP_IN_REGISTER
3328     PL_opsave = op;
3329 #else
3330     SAVEVPTR(PL_op);
3331 #endif
3332
3333     /* we get here either during compilation, or via pp_regcomp at runtime */
3334     runtime = IN_PERL_RUNTIME;
3335     if (runtime)
3336     {
3337         runcv = find_runcv(NULL);
3338
3339         /* At run time, we have to fetch the hints from PL_curcop. */
3340         PL_hints = PL_curcop->cop_hints;
3341         if (PL_hints & HINT_LOCALIZE_HH) {
3342             /* SAVEHINTS created a new HV in PL_hintgv, which we
3343                need to GC */
3344             SvREFCNT_dec(GvHV(PL_hintgv));
3345             GvHV(PL_hintgv) =
3346              refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3347             hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3348         }
3349         SAVECOMPILEWARNINGS();
3350         PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3351         cophh_free(CopHINTHASH_get(&PL_compiling));
3352         /* XXX Does this need to avoid copying a label? */
3353         PL_compiling.cop_hints_hash
3354          = cophh_copy(PL_curcop->cop_hints_hash);
3355     }
3356
3357     PL_op = &dummy;
3358     PL_op->op_type = OP_ENTEREVAL;
3359     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3360     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3361     PUSHEVAL(cx, 0);
3362     need_catch = CATCH_GET;
3363     CATCH_SET(TRUE);
3364
3365     if (runtime)
3366         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
3367     else
3368         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
3369     CATCH_SET(need_catch);
3370     POPBLOCK(cx,PL_curpm);
3371     POPEVAL(cx);
3372
3373     (*startop)->op_type = OP_NULL;
3374     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3375     /* XXX DAPM do this properly one year */
3376     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3377     LEAVE_with_name("eval");
3378     if (IN_PERL_COMPILETIME)
3379         CopHINTS_set(&PL_compiling, PL_hints);
3380 #ifdef OP_IN_REGISTER
3381     op = PL_opsave;
3382 #endif
3383     PERL_UNUSED_VAR(newsp);
3384     PERL_UNUSED_VAR(optype);
3385
3386     return PL_eval_start;
3387 }
3388
3389
3390 /*
3391 =for apidoc find_runcv
3392
3393 Locate the CV corresponding to the currently executing sub or eval.
3394 If db_seqp is non_null, skip CVs that are in the DB package and populate
3395 *db_seqp with the cop sequence number at the point that the DB:: code was
3396 entered. (allows debuggers to eval in the scope of the breakpoint rather
3397 than in the scope of the debugger itself).
3398
3399 =cut
3400 */
3401
3402 CV*
3403 Perl_find_runcv(pTHX_ U32 *db_seqp)
3404 {
3405     dVAR;
3406     PERL_SI      *si;
3407
3408     if (db_seqp)
3409         *db_seqp = PL_curcop->cop_seq;
3410     for (si = PL_curstackinfo; si; si = si->si_prev) {
3411         I32 ix;
3412         for (ix = si->si_cxix; ix >= 0; ix--) {
3413             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3414             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3415                 CV * const cv = cx->blk_sub.cv;
3416                 /* skip DB:: code */
3417                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3418                     *db_seqp = cx->blk_oldcop->cop_seq;
3419                     continue;
3420                 }
3421                 return cv;
3422             }
3423             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3424                 return cx->blk_eval.cv;
3425         }
3426     }
3427     return PL_main_cv;
3428 }
3429
3430
3431 /* Run yyparse() in a setjmp wrapper. Returns:
3432  *   0: yyparse() successful
3433  *   1: yyparse() failed
3434  *   3: yyparse() died
3435  */
3436 STATIC int
3437 S_try_yyparse(pTHX_ int gramtype)
3438 {
3439     int ret;
3440     dJMPENV;
3441
3442     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3443     JMPENV_PUSH(ret);
3444     switch (ret) {
3445     case 0:
3446         ret = yyparse(gramtype) ? 1 : 0;
3447         break;
3448     case 3:
3449         break;
3450     default:
3451         JMPENV_POP;
3452         JMPENV_JUMP(ret);
3453         /* NOTREACHED */
3454     }
3455     JMPENV_POP;
3456     return ret;
3457 }
3458
3459
3460 /* Compile a require/do, an eval '', or a /(?{...})/.
3461  * In the last case, startop is non-null, and contains the address of
3462  * a pointer that should be set to the just-compiled code.
3463  * outside is the lexically enclosing CV (if any) that invoked us.
3464  * Returns a bool indicating whether the compile was successful; if so,
3465  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3466  * pushes undef (also croaks if startop != NULL).
3467  */
3468
3469 /* This function is called from three places, sv_compile_2op, pp_return
3470  * and pp_entereval.  These can be distinguished as follows:
3471  *    sv_compile_2op - startop is non-null
3472  *    pp_require     - startop is null; in_require is true
3473  *    pp_entereval   - stortop is null; in_require is false
3474  */
3475
3476 STATIC bool
3477 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
3478 {
3479     dVAR; dSP;
3480     OP * const saveop = PL_op;
3481     COP * const oldcurcop = PL_curcop;
3482     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3483     int yystatus;
3484     CV *evalcv;
3485
3486     PL_in_eval = (in_require
3487                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3488                   : EVAL_INEVAL);
3489
3490     PUSHMARK(SP);
3491
3492     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3493     CvEVAL_on(evalcv);
3494     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3495     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3496     cxstack[cxstack_ix].blk_gimme = gimme;
3497
3498     CvOUTSIDE_SEQ(evalcv) = seq;
3499     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3500
3501     /* set up a scratch pad */
3502
3503     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3504     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3505
3506
3507     if (!PL_madskills)
3508         SAVEMORTALIZESV(evalcv);        /* must remain until end of current statement */
3509
3510     /* make sure we compile in the right package */
3511
3512     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3513         SAVEGENERICSV(PL_curstash);
3514         PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3515     }
3516     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3517     SAVESPTR(PL_beginav);
3518     PL_beginav = newAV();
3519     SAVEFREESV(PL_beginav);
3520     SAVESPTR(PL_unitcheckav);
3521     PL_unitcheckav = newAV();
3522     SAVEFREESV(PL_unitcheckav);
3523
3524 #ifdef PERL_MAD
3525     SAVEBOOL(PL_madskills);
3526     PL_madskills = 0;
3527 #endif
3528
3529     if (!startop) ENTER_with_name("evalcomp");
3530     SAVESPTR(PL_compcv);
3531     PL_compcv = evalcv;
3532
3533     /* try to compile it */
3534
3535     PL_eval_root = NULL;
3536     PL_curcop = &PL_compiling;
3537     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3538         PL_in_eval |= EVAL_KEEPERR;
3539     else
3540         CLEAR_ERRSV();
3541
3542     if (!startop) {
3543         SAVEHINTS();
3544         if (in_require) {
3545             PL_hints = 0;
3546             hv_clear(GvHV(PL_hintgv));
3547         }
3548         else {
3549             PL_hints = saveop->op_private & OPpEVAL_COPHH
3550                          ? oldcurcop->cop_hints : saveop->op_targ;
3551             if (hh) {
3552                 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3553                 SvREFCNT_dec(GvHV(PL_hintgv));
3554                 GvHV(PL_hintgv) = hh;
3555             }
3556         }
3557         SAVECOMPILEWARNINGS();
3558         if (in_require) {
3559             if (PL_dowarn & G_WARN_ALL_ON)
3560                 PL_compiling.cop_warnings = pWARN_ALL ;
3561             else if (PL_dowarn & G_WARN_ALL_OFF)
3562                 PL_compiling.cop_warnings = pWARN_NONE ;
3563             else
3564                 PL_compiling.cop_warnings = pWARN_STD ;
3565         }
3566         else {
3567             PL_compiling.cop_warnings =
3568                 DUP_WARNINGS(oldcurcop->cop_warnings);
3569             cophh_free(CopHINTHASH_get(&PL_compiling));
3570             if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3571                 /* The label, if present, is the first entry on the chain. So rather
3572                    than writing a blank label in front of it (which involves an
3573                    allocation), just use the next entry in the chain.  */
3574                 PL_compiling.cop_hints_hash
3575                     = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3576                 /* Check the assumption that this removed the label.  */
3577                 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3578             }
3579             else
3580                 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3581         }
3582     }
3583
3584     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3585
3586     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3587      * so honour CATCH_GET and trap it here if necessary */
3588
3589     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3590
3591     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3592         SV **newsp;                     /* Used by POPBLOCK. */
3593         PERL_CONTEXT *cx;
3594         I32 optype;                     /* Used by POPEVAL. */
3595         SV *namesv;
3596
3597         cx = NULL;
3598         namesv = NULL;
3599         PERL_UNUSED_VAR(newsp);
3600         PERL_UNUSED_VAR(optype);
3601
3602         /* note that if yystatus == 3, then the EVAL CX block has already
3603          * been popped, and various vars restored */
3604         PL_op = saveop;
3605         if (yystatus != 3) {
3606             if (PL_eval_root) {
3607                 op_free(PL_eval_root);
3608                 PL_eval_root = NULL;
3609             }
3610             SP = PL_stack_base + POPMARK;       /* pop original mark */
3611             if (!startop) {
3612                 POPBLOCK(cx,PL_curpm);
3613                 POPEVAL(cx);
3614                 namesv = cx->blk_eval.old_namesv;
3615             }
3616             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3617             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3618         }
3619
3620         if (in_require) {
3621             if (!cx) {
3622                 /* If cx is still NULL, it means that we didn't go in the
3623                  * POPEVAL branch. */
3624                 cx = &cxstack[cxstack_ix];
3625                 assert(CxTYPE(cx) == CXt_EVAL);
3626                 namesv = cx->blk_eval.old_namesv;
3627             }
3628             (void)hv_store(GvHVn(PL_incgv),
3629                            SvPVX_const(namesv),
3630                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3631                            &PL_sv_undef, 0);
3632             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3633                        SVfARG(ERRSV
3634                                 ? ERRSV
3635                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3636         }
3637         else if (startop) {
3638             if (yystatus != 3) {
3639                 POPBLOCK(cx,PL_curpm);
3640                 POPEVAL(cx);
3641             }
3642             Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3643                        SVfARG(ERRSV
3644                                 ? ERRSV
3645                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3646         }
3647         else {
3648             if (!*(SvPVx_nolen_const(ERRSV))) {
3649                 sv_setpvs(ERRSV, "Compilation error");
3650             }
3651         }
3652         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3653         PUTBACK;
3654         return FALSE;
3655     }
3656     else if (!startop) LEAVE_with_name("evalcomp");
3657     CopLINE_set(&PL_compiling, 0);
3658     if (startop) {
3659         *startop = PL_eval_root;
3660     } else
3661         SAVEFREEOP(PL_eval_root);
3662
3663     DEBUG_x(dump_eval());
3664
3665     /* Register with debugger: */
3666     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3667         CV * const cv = get_cvs("DB::postponed", 0);
3668         if (cv) {
3669             dSP;
3670             PUSHMARK(SP);
3671             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3672             PUTBACK;
3673             call_sv(MUTABLE_SV(cv), G_DISCARD);
3674         }
3675     }
3676
3677     if (PL_unitcheckav) {
3678         OP *es = PL_eval_start;
3679         call_list(PL_scopestack_ix, PL_unitcheckav);
3680         PL_eval_start = es;
3681     }
3682
3683     /* compiled okay, so do it */
3684
3685     CvDEPTH(evalcv) = 1;
3686     SP = PL_stack_base + POPMARK;               /* pop original mark */
3687     PL_op = saveop;                     /* The caller may need it. */
3688     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3689
3690     PUTBACK;
3691     return TRUE;
3692 }
3693
3694 STATIC PerlIO *
3695 S_check_type_and_open(pTHX_ SV *name)
3696 {
3697     Stat_t st;
3698     const char *p = SvPV_nolen_const(name);
3699     const int st_rc = PerlLIO_stat(p, &st);
3700
3701     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3702
3703     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3704         return NULL;
3705     }
3706
3707 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3708     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3709 #else
3710     return PerlIO_open(p, PERL_SCRIPT_MODE);
3711 #endif
3712 }
3713
3714 #ifndef PERL_DISABLE_PMC
3715 STATIC PerlIO *
3716 S_doopen_pm(pTHX_ SV *name)
3717 {
3718     STRLEN namelen;
3719     const char *p = SvPV_const(name, namelen);
3720
3721     PERL_ARGS_ASSERT_DOOPEN_PM;
3722
3723     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3724         SV *const pmcsv = sv_newmortal();
3725         Stat_t pmcstat;
3726
3727         SvSetSV_nosteal(pmcsv,name);
3728         sv_catpvn(pmcsv, "c", 1);
3729
3730         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3731             return check_type_and_open(pmcsv);
3732     }
3733     return check_type_and_open(name);
3734 }
3735 #else
3736 #  define doopen_pm(name) check_type_and_open(name)
3737 #endif /* !PERL_DISABLE_PMC */
3738
3739 PP(pp_require)
3740 {
3741     dVAR; dSP;
3742     register PERL_CONTEXT *cx;
3743     SV *sv;
3744     const char *name;
3745     STRLEN len;
3746     char * unixname;
3747     STRLEN unixlen;
3748 #ifdef VMS
3749     int vms_unixname = 0;
3750 #endif
3751     const char *tryname = NULL;
3752     SV *namesv = NULL;
3753     const I32 gimme = GIMME_V;
3754     int filter_has_file = 0;
3755     PerlIO *tryrsfp = NULL;
3756     SV *filter_cache = NULL;
3757     SV *filter_state = NULL;
3758     SV *filter_sub = NULL;
3759     SV *hook_sv = NULL;
3760     SV *encoding;
3761     OP *op;
3762
3763     sv = POPs;
3764     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3765         sv = sv_2mortal(new_version(sv));
3766         if (!sv_derived_from(PL_patchlevel, "version"))
3767             upg_version(PL_patchlevel, TRUE);
3768         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3769             if ( vcmp(sv,PL_patchlevel) <= 0 )
3770                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3771                     SVfARG(sv_2mortal(vnormal(sv))),
3772                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3773                 );
3774         }
3775         else {
3776             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3777                 I32 first = 0;
3778                 AV *lav;
3779                 SV * const req = SvRV(sv);
3780                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3781
3782                 /* get the left hand term */
3783                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3784
3785                 first  = SvIV(*av_fetch(lav,0,0));
3786                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3787                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3788                     || av_len(lav) > 1               /* FP with > 3 digits */
3789                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3790                    ) {
3791                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3792                         "%"SVf", stopped",
3793                         SVfARG(sv_2mortal(vnormal(req))),
3794                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3795                     );
3796                 }
3797                 else { /* probably 'use 5.10' or 'use 5.8' */
3798                     SV *hintsv;
3799                     I32 second = 0;
3800
3801                     if (av_len(lav)>=1)
3802                         second = SvIV(*av_fetch(lav,1,0));
3803
3804                     second /= second >= 600  ? 100 : 10;
3805                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3806                                            (int)first, (int)second);
3807                     upg_version(hintsv, TRUE);
3808
3809                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3810                         "--this is only %"SVf", stopped",
3811                         SVfARG(sv_2mortal(vnormal(req))),
3812                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3813                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3814                     );
3815                 }
3816             }
3817         }
3818
3819         RETPUSHYES;
3820     }
3821     name = SvPV_const(sv, len);
3822     if (!(name && len > 0 && *name))
3823         DIE(aTHX_ "Null filename used");
3824     TAINT_PROPER("require");
3825
3826
3827 #ifdef VMS
3828     /* The key in the %ENV hash is in the syntax of file passed as the argument
3829      * usually this is in UNIX format, but sometimes in VMS format, which
3830      * can result in a module being pulled in more than once.
3831      * To prevent this, the key must be stored in UNIX format if the VMS
3832      * name can be translated to UNIX.
3833      */
3834     if ((unixname = tounixspec(name, NULL)) != NULL) {
3835         unixlen = strlen(unixname);
3836         vms_unixname = 1;
3837     }
3838     else
3839 #endif
3840     {
3841         /* if not VMS or VMS name can not be translated to UNIX, pass it
3842          * through.
3843          */
3844         unixname = (char *) name;
3845         unixlen = len;
3846     }
3847     if (PL_op->op_type == OP_REQUIRE) {
3848         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3849                                           unixname, unixlen, 0);
3850         if ( svp ) {
3851             if (*svp != &PL_sv_undef)
3852                 RETPUSHYES;
3853             else
3854                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3855                             "Compilation failed in require", unixname);
3856         }
3857     }
3858
3859     /* prepare to compile file */
3860
3861     if (path_is_absolute(name)) {
3862         /* At this point, name is SvPVX(sv)  */
3863         tryname = name;
3864         tryrsfp = doopen_pm(sv);
3865     }
3866     if (!tryrsfp) {
3867         AV * const ar = GvAVn(PL_incgv);
3868         I32 i;
3869 #ifdef VMS
3870         if (vms_unixname)
3871 #endif
3872         {
3873             namesv = newSV_type(SVt_PV);
3874             for (i = 0; i <= AvFILL(ar); i++) {
3875                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3876
3877                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3878                     mg_get(dirsv);
3879                 if (SvROK(dirsv)) {
3880                     int count;
3881                     SV **svp;
3882                     SV *loader = dirsv;
3883
3884                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3885                         && !sv_isobject(loader))
3886                     {
3887                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3888                     }
3889
3890                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3891                                    PTR2UV(SvRV(dirsv)), name);
3892                     tryname = SvPVX_const(namesv);
3893                     tryrsfp = NULL;
3894
3895                     ENTER_with_name("call_INC");
3896                     SAVETMPS;
3897                     EXTEND(SP, 2);
3898
3899                     PUSHMARK(SP);
3900                     PUSHs(dirsv);
3901                     PUSHs(sv);
3902                     PUTBACK;
3903                     if (sv_isobject(loader))
3904                         count = call_method("INC", G_ARRAY);
3905                     else
3906                         count = call_sv(loader, G_ARRAY);
3907                     SPAGAIN;
3908
3909                     if (count > 0) {
3910                         int i = 0;
3911                         SV *arg;
3912
3913                         SP -= count - 1;
3914                         arg = SP[i++];
3915
3916                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3917                             && !isGV_with_GP(SvRV(arg))) {
3918                             filter_cache = SvRV(arg);
3919                             SvREFCNT_inc_simple_void_NN(filter_cache);
3920
3921                             if (i < count) {
3922                                 arg = SP[i++];
3923                             }
3924                         }
3925
3926                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3927                             arg = SvRV(arg);
3928                         }
3929
3930                         if (isGV_with_GP(arg)) {
3931                             IO * const io = GvIO((const GV *)arg);
3932
3933                             ++filter_has_file;
3934
3935                             if (io) {
3936                                 tryrsfp = IoIFP(io);
3937                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3938                                     PerlIO_close(IoOFP(io));
3939                                 }
3940                                 IoIFP(io) = NULL;
3941                                 IoOFP(io) = NULL;
3942                             }
3943
3944                             if (i < count) {
3945                                 arg = SP[i++];
3946                             }
3947                         }
3948
3949                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3950                             filter_sub = arg;
3951                             SvREFCNT_inc_simple_void_NN(filter_sub);
3952
3953                             if (i < count) {
3954                                 filter_state = SP[i];
3955                                 SvREFCNT_inc_simple_void(filter_state);
3956                             }
3957                         }
3958
3959                         if (!tryrsfp && (filter_cache || filter_sub)) {
3960                             tryrsfp = PerlIO_open(BIT_BUCKET,
3961                                                   PERL_SCRIPT_MODE);
3962                         }
3963                         SP--;
3964                     }
3965
3966                     PUTBACK;
3967                     FREETMPS;
3968                     LEAVE_with_name("call_INC");
3969
3970                     /* Adjust file name if the hook has set an %INC entry.
3971                        This needs to happen after the FREETMPS above.  */
3972                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3973                     if (svp)
3974                         tryname = SvPV_nolen_const(*svp);
3975
3976                     if (tryrsfp) {
3977                         hook_sv = dirsv;
3978                         break;
3979                     }
3980
3981                     filter_has_file = 0;
3982                     if (filter_cache) {
3983                         SvREFCNT_dec(filter_cache);
3984                         filter_cache = NULL;
3985                     }
3986                     if (filter_state) {
3987                         SvREFCNT_dec(filter_state);
3988                         filter_state = NULL;
3989                     }
3990                     if (filter_sub) {
3991                         SvREFCNT_dec(filter_sub);
3992                         filter_sub = NULL;
3993                     }
3994                 }
3995                 else {
3996                   if (!path_is_absolute(name)
3997                   ) {
3998                     const char *dir;
3999                     STRLEN dirlen;
4000
4001                     if (SvOK(dirsv)) {
4002                         dir = SvPV_const(dirsv, dirlen);
4003                     } else {
4004                         dir = "";
4005                         dirlen = 0;
4006                     }
4007
4008 #ifdef VMS
4009                     char *unixdir;
4010                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
4011                         continue;
4012                     sv_setpv(namesv, unixdir);
4013                     sv_catpv(namesv, unixname);
4014 #else
4015 #  ifdef __SYMBIAN32__
4016                     if (PL_origfilename[0] &&
4017                         PL_origfilename[1] == ':' &&
4018                         !(dir[0] && dir[1] == ':'))
4019                         Perl_sv_setpvf(aTHX_ namesv,
4020                                        "%c:%s\\%s",
4021                                        PL_origfilename[0],
4022                                        dir, name);
4023                     else
4024                         Perl_sv_setpvf(aTHX_ namesv,
4025                                        "%s\\%s",
4026                                        dir, name);
4027 #  else
4028                     /* The equivalent of
4029                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4030                        but without the need to parse the format string, or
4031                        call strlen on either pointer, and with the correct
4032                        allocation up front.  */
4033                     {
4034                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4035
4036                         memcpy(tmp, dir, dirlen);
4037                         tmp +=dirlen;
4038                         *tmp++ = '/';
4039                         /* name came from an SV, so it will have a '\0' at the
4040                            end that we can copy as part of this memcpy().  */
4041                         memcpy(tmp, name, len + 1);
4042
4043                         SvCUR_set(namesv, dirlen + len + 1);
4044                         SvPOK_on(namesv);
4045                     }
4046 #  endif
4047 #endif
4048                     TAINT_PROPER("require");
4049                     tryname = SvPVX_const(namesv);
4050                     tryrsfp = doopen_pm(namesv);
4051                     if (tryrsfp) {
4052                         if (tryname[0] == '.' && tryname[1] == '/') {
4053                             ++tryname;
4054                             while (*++tryname == '/');
4055                         }
4056                         break;
4057                     }
4058                     else if (errno == EMFILE)
4059                         /* no point in trying other paths if out of handles */
4060                         break;
4061                   }
4062                 }
4063             }
4064         }
4065     }
4066     sv_2mortal(namesv);
4067     if (!tryrsfp) {
4068         if (PL_op->op_type == OP_REQUIRE) {
4069             if(errno == EMFILE) {
4070                 /* diag_listed_as: Can't locate %s */
4071                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
4072             } else {
4073                 if (namesv) {                   /* did we lookup @INC? */
4074                     AV * const ar = GvAVn(PL_incgv);
4075                     I32 i;
4076                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4077                     for (i = 0; i <= AvFILL(ar); i++) {
4078                         sv_catpvs(inc, " ");
4079                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4080                     }
4081
4082                     /* diag_listed_as: Can't locate %s */
4083                     DIE(aTHX_
4084                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4085                         name,
4086                         (memEQ(name + len - 2, ".h", 3)
4087                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4088                         (memEQ(name + len - 3, ".ph", 4)
4089                          ? " (did you run h2ph?)" : ""),
4090                         inc
4091                         );
4092                 }
4093             }
4094             DIE(aTHX_ "Can't locate %s", name);
4095         }
4096
4097         RETPUSHUNDEF;
4098     }
4099     else
4100         SETERRNO(0, SS_NORMAL);
4101
4102     /* Assume success here to prevent recursive requirement. */
4103     /* name is never assigned to again, so len is still strlen(name)  */
4104     /* Check whether a hook in @INC has already filled %INC */
4105     if (!hook_sv) {
4106         (void)hv_store(GvHVn(PL_incgv),
4107                        unixname, unixlen, newSVpv(tryname,0),0);
4108     } else {
4109         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4110         if (!svp)
4111             (void)hv_store(GvHVn(PL_incgv),
4112                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4113     }
4114
4115     ENTER_with_name("eval");
4116     SAVETMPS;
4117     SAVECOPFILE_FREE(&PL_compiling);
4118     CopFILE_set(&PL_compiling, tryname);
4119     lex_start(NULL, tryrsfp, 0);
4120
4121     if (filter_sub || filter_cache) {
4122         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4123            than hanging another SV from it. In turn, filter_add() optionally
4124            takes the SV to use as the filter (or creates a new SV if passed
4125            NULL), so simply pass in whatever value filter_cache has.  */
4126         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4127         IoLINES(datasv) = filter_has_file;
4128         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4129         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4130     }
4131
4132     /* switch to eval mode */
4133     PUSHBLOCK(cx, CXt_EVAL, SP);
4134     PUSHEVAL(cx, name);
4135     cx->blk_eval.retop = PL_op->op_next;
4136
4137     SAVECOPLINE(&PL_compiling);
4138     CopLINE_set(&PL_compiling, 0);
4139
4140     PUTBACK;
4141
4142     /* Store and reset encoding. */
4143     encoding = PL_encoding;
4144     PL_encoding = NULL;
4145
4146     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
4147         op = DOCATCH(PL_eval_start);
4148     else
4149         op = PL_op->op_next;
4150
4151     /* Restore encoding. */
4152     PL_encoding = encoding;
4153
4154     return op;
4155 }
4156
4157 /* This is a op added to hold the hints hash for
4158    pp_entereval. The hash can be modified by the code
4159    being eval'ed, so we return a copy instead. */
4160
4161 PP(pp_hintseval)
4162 {
4163     dVAR;
4164     dSP;
4165     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4166     RETURN;
4167 }
4168
4169
4170 PP(pp_entereval)
4171 {
4172     dVAR; dSP;
4173     register PERL_CONTEXT *cx;
4174     SV *sv;
4175     const I32 gimme = GIMME_V;
4176     const U32 was = PL_breakable_sub_gen;
4177     char tbuf[TYPE_DIGITS(long) + 12];
4178     bool saved_delete = FALSE;
4179     char *tmpbuf = tbuf;
4180     STRLEN len;
4181     CV* runcv;
4182     U32 seq, lex_flags = 0;
4183     HV *saved_hh = NULL;
4184     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4185
4186     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4187         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4188     }
4189     else if (PL_hints & HINT_LOCALIZE_HH || (
4190                 PL_op->op_private & OPpEVAL_COPHH
4191              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4192             )) {
4193         saved_hh = cop_hints_2hv(PL_curcop, 0);
4194         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4195     }
4196     sv = POPs;
4197     if (!SvPOK(sv)) {
4198         /* make sure we've got a plain PV (no overload etc) before testing
4199          * for taint. Making a copy here is probably overkill, but better
4200          * safe than sorry */
4201         STRLEN len;
4202         const char * const p = SvPV_const(sv, len);
4203
4204         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4205         lex_flags |= LEX_START_COPIED;
4206
4207         if (bytes && SvUTF8(sv))
4208             SvPVbyte_force(sv, len);
4209     }
4210     else if (bytes && SvUTF8(sv)) {
4211         /* Don't modify someone else's scalar */
4212         STRLEN len;
4213         sv = newSVsv(sv);
4214         (void)sv_2mortal(sv);
4215         SvPVbyte_force(sv,len);
4216         lex_flags |= LEX_START_COPIED;
4217     }
4218
4219     TAINT_IF(SvTAINTED(sv));
4220     TAINT_PROPER("eval");
4221
4222     ENTER_with_name("eval");
4223     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4224                            ? LEX_IGNORE_UTF8_HINTS
4225                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4226                         )
4227              );
4228     SAVETMPS;
4229
4230     /* switch to eval mode */
4231
4232     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4233         SV * const temp_sv = sv_newmortal();
4234         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4235                        (unsigned long)++PL_evalseq,
4236                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4237         tmpbuf = SvPVX(temp_sv);
4238         len = SvCUR(temp_sv);
4239     }
4240     else
4241         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4242     SAVECOPFILE_FREE(&PL_compiling);
4243     CopFILE_set(&PL_compiling, tmpbuf+2);
4244     SAVECOPLINE(&PL_compiling);
4245     CopLINE_set(&PL_compiling, 1);
4246     /* special case: an eval '' executed within the DB package gets lexically
4247      * placed in the first non-DB CV rather than the current CV - this
4248      * allows the debugger to execute code, find lexicals etc, in the
4249      * scope of the code being debugged. Passing &seq gets find_runcv
4250      * to do the dirty work for us */
4251     runcv = find_runcv(&seq);
4252
4253     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4254     PUSHEVAL(cx, 0);
4255     cx->blk_eval.retop = PL_op->op_next;
4256
4257     /* prepare to compile string */
4258
4259     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4260         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4261     else {
4262         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4263            deleting the eval's FILEGV from the stash before gv_check() runs
4264            (i.e. before run-time proper). To work around the coredump that
4265            ensues, we always turn GvMULTI_on for any globals that were
4266            introduced within evals. See force_ident(). GSAR 96-10-12 */
4267         char *const safestr = savepvn(tmpbuf, len);
4268         SAVEDELETE(PL_defstash, safestr, len);
4269         saved_delete = TRUE;
4270     }
4271
4272     PUTBACK;
4273
4274     if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
4275         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4276             ? (PERLDB_LINE || PERLDB_SAVESRC)
4277             :  PERLDB_SAVESRC_NOSUBS) {
4278             /* Retain the filegv we created.  */
4279         } else if (!saved_delete) {
4280             char *const safestr = savepvn(tmpbuf, len);
4281             SAVEDELETE(PL_defstash, safestr, len);
4282         }
4283         return DOCATCH(PL_eval_start);
4284     } else {
4285         /* We have already left the scope set up earlier thanks to the LEAVE
4286            in doeval().  */
4287         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4288             ? (PERLDB_LINE || PERLDB_SAVESRC)
4289             :  PERLDB_SAVESRC_INVALID) {
4290             /* Retain the filegv we created.  */
4291         } else if (!saved_delete) {
4292             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4293         }
4294         return PL_op->op_next;
4295     }
4296 }
4297
4298 PP(pp_leaveeval)
4299 {
4300     dVAR; dSP;
4301     SV **newsp;
4302     PMOP *newpm;
4303     I32 gimme;
4304     register PERL_CONTEXT *cx;
4305     OP *retop;
4306     const U8 save_flags = PL_op -> op_flags;
4307     I32 optype;
4308     SV *namesv;
4309     CV *evalcv;
4310
4311     PERL_ASYNC_CHECK();
4312     POPBLOCK(cx,newpm);
4313     POPEVAL(cx);
4314     namesv = cx->blk_eval.old_namesv;
4315     retop = cx->blk_eval.retop;
4316     evalcv = cx->blk_eval.cv;
4317
4318     TAINT_NOT;
4319     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4320                                 gimme, SVs_TEMP);
4321     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4322
4323 #ifdef DEBUGGING
4324     assert(CvDEPTH(evalcv) == 1);
4325 #endif
4326     CvDEPTH(evalcv) = 0;
4327
4328     if (optype == OP_REQUIRE &&
4329         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4330     {
4331         /* Unassume the success we assumed earlier. */
4332         (void)hv_delete(GvHVn(PL_incgv),
4333                         SvPVX_const(namesv),
4334                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4335                         G_DISCARD);
4336         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4337                                SVfARG(namesv));
4338         /* die_unwind() did LEAVE, or we won't be here */
4339     }
4340     else {
4341         LEAVE_with_name("eval");
4342         if (!(save_flags & OPf_SPECIAL)) {
4343             CLEAR_ERRSV();
4344         }
4345     }
4346
4347     RETURNOP(retop);
4348 }
4349
4350 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4351    close to the related Perl_create_eval_scope.  */
4352 void
4353 Perl_delete_eval_scope(pTHX)
4354 {
4355     SV **newsp;
4356     PMOP *newpm;
4357     I32 gimme;
4358     register PERL_CONTEXT *cx;
4359     I32 optype;
4360
4361     POPBLOCK(cx,newpm);
4362     POPEVAL(cx);
4363     PL_curpm = newpm;
4364     LEAVE_with_name("eval_scope");
4365     PERL_UNUSED_VAR(newsp);
4366     PERL_UNUSED_VAR(gimme);
4367     PERL_UNUSED_VAR(optype);
4368 }
4369
4370 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4371    also needed by Perl_fold_constants.  */
4372 PERL_CONTEXT *
4373 Perl_create_eval_scope(pTHX_ U32 flags)
4374 {
4375     PERL_CONTEXT *cx;
4376     const I32 gimme = GIMME_V;
4377
4378     ENTER_with_name("eval_scope");
4379     SAVETMPS;
4380
4381     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4382     PUSHEVAL(cx, 0);
4383
4384     PL_in_eval = EVAL_INEVAL;
4385     if (flags & G_KEEPERR)
4386         PL_in_eval |= EVAL_KEEPERR;
4387     else
4388         CLEAR_ERRSV();
4389     if (flags & G_FAKINGEVAL) {
4390         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4391     }
4392     return cx;
4393 }
4394
4395 PP(pp_entertry)
4396 {
4397     dVAR;
4398     PERL_CONTEXT * const cx = create_eval_scope(0);
4399     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4400     return DOCATCH(PL_op->op_next);
4401 }
4402
4403 PP(pp_leavetry)
4404 {
4405     dVAR; dSP;
4406     SV **newsp;
4407     PMOP *newpm;
4408     I32 gimme;
4409     register PERL_CONTEXT *cx;
4410     I32 optype;
4411
4412     PERL_ASYNC_CHECK();
4413     POPBLOCK(cx,newpm);
4414     POPEVAL(cx);
4415     PERL_UNUSED_VAR(optype);
4416
4417     TAINT_NOT;
4418     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4419     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4420
4421     LEAVE_with_name("eval_scope");
4422     CLEAR_ERRSV();
4423     RETURN;
4424 }
4425
4426 PP(pp_entergiven)
4427 {
4428     dVAR; dSP;
4429     register PERL_CONTEXT *cx;
4430     const I32 gimme = GIMME_V;
4431
4432     ENTER_with_name("given");
4433     SAVETMPS;
4434
4435     SAVECLEARSV(PAD_SVl(PL_op->op_targ));
4436     sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4437
4438     PUSHBLOCK(cx, CXt_GIVEN, SP);
4439     PUSHGIVEN(cx);
4440
4441     RETURN;
4442 }
4443
4444 PP(pp_leavegiven)
4445 {
4446     dVAR; dSP;
4447     register PERL_CONTEXT *cx;
4448     I32 gimme;
4449     SV **newsp;
4450     PMOP *newpm;
4451     PERL_UNUSED_CONTEXT;
4452
4453     POPBLOCK(cx,newpm);
4454     assert(CxTYPE(cx) == CXt_GIVEN);
4455
4456     TAINT_NOT;
4457     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4458     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4459
4460     LEAVE_with_name("given");
4461     RETURN;
4462 }
4463
4464 /* Helper routines used by pp_smartmatch */
4465 STATIC PMOP *
4466 S_make_matcher(pTHX_ REGEXP *re)
4467 {
4468     dVAR;
4469     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4470
4471     PERL_ARGS_ASSERT_MAKE_MATCHER;
4472
4473     PM_SETRE(matcher, ReREFCNT_inc(re));
4474
4475     SAVEFREEOP((OP *) matcher);
4476     ENTER_with_name("matcher"); SAVETMPS;
4477     SAVEOP();
4478     return matcher;
4479 }
4480
4481 STATIC bool
4482 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4483 {
4484     dVAR;
4485     dSP;
4486
4487     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4488
4489     PL_op = (OP *) matcher;
4490     XPUSHs(sv);
4491     PUTBACK;
4492     (void) Perl_pp_match(aTHX);
4493     SPAGAIN;
4494     return (SvTRUEx(POPs));
4495 }
4496
4497 STATIC void
4498 S_destroy_matcher(pTHX_ PMOP *matcher)
4499 {
4500     dVAR;
4501
4502     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4503     PERL_UNUSED_ARG(matcher);
4504
4505     FREETMPS;
4506     LEAVE_with_name("matcher");
4507 }
4508
4509 /* Do a smart match */
4510 PP(pp_smartmatch)
4511 {
4512     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4513     return do_smartmatch(NULL, NULL, 0);
4514 }
4515
4516 /* This version of do_smartmatch() implements the
4517  * table of smart matches that is found in perlsyn.
4518  */
4519 STATIC OP *
4520 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4521 {
4522     dVAR;
4523     dSP;
4524
4525     bool object_on_left = FALSE;
4526     SV *e = TOPs;       /* e is for 'expression' */
4527     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4528
4529     /* Take care only to invoke mg_get() once for each argument.
4530      * Currently we do this by copying the SV if it's magical. */
4531     if (d) {
4532         if (!copied && SvGMAGICAL(d))
4533             d = sv_mortalcopy(d);
4534     }
4535     else
4536         d = &PL_sv_undef;
4537
4538     assert(e);
4539     if (SvGMAGICAL(e))
4540         e = sv_mortalcopy(e);
4541
4542     /* First of all, handle overload magic of the rightmost argument */
4543     if (SvAMAGIC(e)) {
4544         SV * tmpsv;
4545         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4546         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4547
4548         tmpsv = amagic_call(d, e, smart_amg, 0);
4549         if (tmpsv) {
4550             SPAGAIN;
4551             (void)POPs;
4552             SETs(tmpsv);
4553             RETURN;
4554         }
4555         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4556     }
4557
4558     SP -= 2;    /* Pop the values */
4559
4560
4561     /* ~~ undef */
4562     if (!SvOK(e)) {
4563         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4564         if (SvOK(d))
4565             RETPUSHNO;
4566         else
4567             RETPUSHYES;
4568     }
4569
4570     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4571         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4572         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4573     }
4574     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4575         object_on_left = TRUE;
4576
4577     /* ~~ sub */
4578     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4579         I32 c;
4580         if (object_on_left) {
4581             goto sm_any_sub; /* Treat objects like scalars */
4582         }
4583         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4584             /* Test sub truth for each key */
4585             HE *he;
4586             bool andedresults = TRUE;
4587             HV *hv = (HV*) SvRV(d);
4588             I32 numkeys = hv_iterinit(hv);
4589             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4590             if (numkeys == 0)
4591                 RETPUSHYES;
4592             while ( (he = hv_iternext(hv)) ) {
4593                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4594                 ENTER_with_name("smartmatch_hash_key_test");
4595                 SAVETMPS;
4596                 PUSHMARK(SP);
4597                 PUSHs(hv_iterkeysv(he));
4598                 PUTBACK;
4599                 c = call_sv(e, G_SCALAR);
4600                 SPAGAIN;
4601                 if (c == 0)
4602                     andedresults = FALSE;
4603                 else
4604                     andedresults = SvTRUEx(POPs) && andedresults;
4605                 FREETMPS;
4606                 LEAVE_with_name("smartmatch_hash_key_test");
4607             }
4608             if (andedresults)
4609                 RETPUSHYES;
4610             else
4611                 RETPUSHNO;
4612         }
4613         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4614             /* Test sub truth for each element */
4615             I32 i;
4616             bool andedresults = TRUE;
4617             AV *av = (AV*) SvRV(d);
4618             const I32 len = av_len(av);
4619             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4620             if (len == -1)
4621                 RETPUSHYES;
4622             for (i = 0; i <= len; ++i) {
4623                 SV * const * const svp = av_fetch(av, i, FALSE);
4624                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4625                 ENTER_with_name("smartmatch_array_elem_test");
4626                 SAVETMPS;
4627                 PUSHMARK(SP);
4628                 if (svp)
4629                     PUSHs(*svp);
4630                 PUTBACK;
4631                 c = call_sv(e, G_SCALAR);
4632                 SPAGAIN;
4633                 if (c == 0)
4634                     andedresults = FALSE;
4635                 else
4636                     andedresults = SvTRUEx(POPs) && andedresults;
4637                 FREETMPS;
4638                 LEAVE_with_name("smartmatch_array_elem_test");
4639             }
4640             if (andedresults)
4641                 RETPUSHYES;
4642             else
4643                 RETPUSHNO;
4644         }
4645         else {
4646           sm_any_sub:
4647             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4648             ENTER_with_name("smartmatch_coderef");
4649             SAVETMPS;
4650             PUSHMARK(SP);
4651             PUSHs(d);
4652             PUTBACK;
4653             c = call_sv(e, G_SCALAR);
4654             SPAGAIN;
4655             if (c == 0)
4656                 PUSHs(&PL_sv_no);
4657             else if (SvTEMP(TOPs))
4658                 SvREFCNT_inc_void(TOPs);
4659             FREETMPS;
4660             LEAVE_with_name("smartmatch_coderef");
4661             RETURN;
4662         }
4663     }
4664     /* ~~ %hash */
4665     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4666         if (object_on_left) {
4667             goto sm_any_hash; /* Treat objects like scalars */
4668         }
4669         else if (!SvOK(d)) {
4670             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4671             RETPUSHNO;
4672         }
4673         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4674             /* Check that the key-sets are identical */
4675             HE *he;
4676             HV *other_hv = MUTABLE_HV(SvRV(d));
4677             bool tied = FALSE;
4678             bool other_tied = FALSE;
4679             U32 this_key_count  = 0,
4680                 other_key_count = 0;
4681             HV *hv = MUTABLE_HV(SvRV(e));
4682
4683             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4684             /* Tied hashes don't know how many keys they have. */
4685             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4686                 tied = TRUE;
4687             }
4688             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4689                 HV * const temp = other_hv;
4690                 other_hv = hv;
4691                 hv = temp;
4692                 tied = TRUE;
4693             }
4694             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4695                 other_tied = TRUE;
4696
4697             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4698                 RETPUSHNO;
4699
4700             /* The hashes have the same number of keys, so it suffices
4701                to check that one is a subset of the other. */
4702             (void) hv_iterinit(hv);
4703             while ( (he = hv_iternext(hv)) ) {
4704                 SV *key = hv_iterkeysv(he);
4705
4706                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4707                 ++ this_key_count;
4708
4709                 if(!hv_exists_ent(other_hv, key, 0)) {
4710                     (void) hv_iterinit(hv);     /* reset iterator */
4711                     RETPUSHNO;
4712                 }
4713             }
4714
4715             if (other_tied) {
4716                 (void) hv_iterinit(other_hv);
4717                 while ( hv_iternext(other_hv) )
4718                     ++other_key_count;
4719             }
4720             else
4721                 other_key_count = HvUSEDKEYS(other_hv);
4722
4723             if (this_key_count != other_key_count)
4724                 RETPUSHNO;
4725             else
4726                 RETPUSHYES;
4727         }
4728         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4729             AV * const other_av = MUTABLE_AV(SvRV(d));
4730             const I32 other_len = av_len(other_av) + 1;
4731             I32 i;
4732             HV *hv = MUTABLE_HV(SvRV(e));
4733
4734             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4735             for (i = 0; i < other_len; ++i) {
4736                 SV ** const svp = av_fetch(other_av, i, FALSE);
4737                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4738                 if (svp) {      /* ??? When can this not happen? */
4739                     if (hv_exists_ent(hv, *svp, 0))
4740                         RETPUSHYES;
4741                 }
4742             }
4743             RETPUSHNO;
4744         }
4745         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4746             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4747           sm_regex_hash:
4748             {
4749                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4750                 HE *he;
4751                 HV *hv = MUTABLE_HV(SvRV(e));
4752
4753                 (void) hv_iterinit(hv);
4754                 while ( (he = hv_iternext(hv)) ) {
4755                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4756                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4757                         (void) hv_iterinit(hv);
4758                         destroy_matcher(matcher);
4759                         RETPUSHYES;
4760                     }
4761                 }
4762                 destroy_matcher(matcher);
4763                 RETPUSHNO;
4764             }
4765         }
4766         else {
4767           sm_any_hash:
4768             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4769             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4770                 RETPUSHYES;
4771             else
4772                 RETPUSHNO;
4773         }
4774     }
4775     /* ~~ @array */
4776     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4777         if (object_on_left) {
4778             goto sm_any_array; /* Treat objects like scalars */
4779         }
4780         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4781             AV * const other_av = MUTABLE_AV(SvRV(e));
4782             const I32 other_len = av_len(other_av) + 1;
4783             I32 i;
4784
4785             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4786             for (i = 0; i < other_len; ++i) {
4787                 SV ** const svp = av_fetch(other_av, i, FALSE);
4788
4789                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4790                 if (svp) {      /* ??? When can this not happen? */
4791                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4792                         RETPUSHYES;
4793                 }
4794             }
4795             RETPUSHNO;
4796         }
4797         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4798             AV *other_av = MUTABLE_AV(SvRV(d));
4799             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4800             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4801                 RETPUSHNO;
4802             else {
4803                 I32 i;
4804                 const I32 other_len = av_len(other_av);
4805
4806                 if (NULL == seen_this) {
4807                     seen_this = newHV();
4808                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4809                 }
4810                 if (NULL == seen_other) {
4811                     seen_other = newHV();
4812                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4813                 }
4814                 for(i = 0; i <= other_len; ++i) {
4815                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4816                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4817
4818                     if (!this_elem || !other_elem) {
4819                         if ((this_elem && SvOK(*this_elem))
4820                                 || (other_elem && SvOK(*other_elem)))
4821                             RETPUSHNO;
4822                     }
4823                     else if (hv_exists_ent(seen_this,
4824                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4825                             hv_exists_ent(seen_other,
4826                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4827                     {
4828                         if (*this_elem != *other_elem)
4829                             RETPUSHNO;
4830                     }
4831                     else {
4832                         (void)hv_store_ent(seen_this,
4833                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4834                                 &PL_sv_undef, 0);
4835                         (void)hv_store_ent(seen_other,
4836                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4837                                 &PL_sv_undef, 0);
4838                         PUSHs(*other_elem);
4839                         PUSHs(*this_elem);
4840
4841                         PUTBACK;
4842                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4843                         (void) do_smartmatch(seen_this, seen_other, 0);
4844                         SPAGAIN;
4845                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4846
4847                         if (!SvTRUEx(POPs))
4848                             RETPUSHNO;
4849                     }
4850                 }
4851                 RETPUSHYES;
4852             }
4853         }
4854         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4855             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4856           sm_regex_array:
4857             {
4858                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4859                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4860                 I32 i;
4861
4862                 for(i = 0; i <= this_len; ++i) {
4863                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4864                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4865                     if (svp && matcher_matches_sv(matcher, *svp)) {
4866                         destroy_matcher(matcher);
4867                         RETPUSHYES;
4868                     }
4869                 }
4870                 destroy_matcher(matcher);
4871                 RETPUSHNO;
4872             }
4873         }
4874         else if (!SvOK(d)) {
4875             /* undef ~~ array */
4876             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4877             I32 i;
4878
4879             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4880             for (i = 0; i <= this_len; ++i) {
4881                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4882                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4883                 if (!svp || !SvOK(*svp))
4884                     RETPUSHYES;
4885             }
4886             RETPUSHNO;
4887         }
4888         else {
4889           sm_any_array:
4890             {
4891                 I32 i;
4892                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4893
4894                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4895                 for (i = 0; i <= this_len; ++i) {
4896                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4897                     if (!svp)
4898                         continue;
4899
4900                     PUSHs(d);
4901                     PUSHs(*svp);
4902                     PUTBACK;
4903                     /* infinite recursion isn't supposed to happen here */
4904                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4905                     (void) do_smartmatch(NULL, NULL, 1);
4906                     SPAGAIN;
4907                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4908                     if (SvTRUEx(POPs))
4909                         RETPUSHYES;
4910                 }
4911                 RETPUSHNO;
4912             }
4913         }
4914     }
4915     /* ~~ qr// */
4916     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4917         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4918             SV *t = d; d = e; e = t;
4919             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4920             goto sm_regex_hash;
4921         }
4922         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4923             SV *t = d; d = e; e = t;
4924             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4925             goto sm_regex_array;
4926         }
4927         else {
4928             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4929
4930             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4931             PUTBACK;
4932             PUSHs(matcher_matches_sv(matcher, d)
4933                     ? &PL_sv_yes
4934                     : &PL_sv_no);
4935             destroy_matcher(matcher);
4936             RETURN;
4937         }
4938     }
4939     /* ~~ scalar */
4940     /* See if there is overload magic on left */
4941     else if (object_on_left && SvAMAGIC(d)) {
4942         SV *tmpsv;
4943         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4944         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4945         PUSHs(d); PUSHs(e);
4946         PUTBACK;
4947         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4948         if (tmpsv) {
4949             SPAGAIN;
4950             (void)POPs;
4951             SETs(tmpsv);
4952             RETURN;
4953         }
4954         SP -= 2;
4955         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4956         goto sm_any_scalar;
4957     }
4958     else if (!SvOK(d)) {
4959         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4960         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4961         RETPUSHNO;
4962     }
4963     else
4964   sm_any_scalar:
4965     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4966         DEBUG_M(if (SvNIOK(e))
4967                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4968                 else
4969                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4970         );
4971         /* numeric comparison */
4972         PUSHs(d); PUSHs(e);
4973         PUTBACK;
4974         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4975             (void) Perl_pp_i_eq(aTHX);
4976         else
4977             (void) Perl_pp_eq(aTHX);
4978         SPAGAIN;
4979         if (SvTRUEx(POPs))
4980             RETPUSHYES;
4981         else
4982             RETPUSHNO;
4983     }
4984
4985     /* As a last resort, use string comparison */
4986     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4987     PUSHs(d); PUSHs(e);
4988     PUTBACK;
4989     return Perl_pp_seq(aTHX);
4990 }
4991
4992 PP(pp_enterwhen)
4993 {
4994     dVAR; dSP;
4995     register PERL_CONTEXT *cx;
4996     const I32 gimme = GIMME_V;
4997
4998     /* This is essentially an optimization: if the match
4999        fails, we don't want to push a context and then
5000        pop it again right away, so we skip straight
5001        to the op that follows the leavewhen.
5002        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5003     */
5004     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
5005         RETURNOP(cLOGOP->op_other->op_next);
5006
5007     ENTER_with_name("when");
5008     SAVETMPS;
5009
5010     PUSHBLOCK(cx, CXt_WHEN, SP);
5011     PUSHWHEN(cx);
5012
5013     RETURN;
5014 }
5015
5016 PP(pp_leavewhen)
5017 {
5018     dVAR; dSP;
5019     I32 cxix;
5020     register PERL_CONTEXT *cx;
5021     I32 gimme;
5022     SV **newsp;
5023     PMOP *newpm;
5024
5025     cxix = dopoptogiven(cxstack_ix);
5026     if (cxix < 0)
5027         DIE(aTHX_ "Can't use when() outside a topicalizer");
5028
5029     POPBLOCK(cx,newpm);
5030     assert(CxTYPE(cx) == CXt_WHEN);
5031
5032     TAINT_NOT;
5033     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
5034     PL_curpm = newpm;   /* pop $1 et al */
5035
5036     LEAVE_with_name("when");
5037
5038     if (cxix < cxstack_ix)
5039         dounwind(cxix);
5040
5041     cx = &cxstack[cxix];
5042
5043     if (CxFOREACH(cx)) {
5044         /* clear off anything above the scope we're re-entering */
5045         I32 inner = PL_scopestack_ix;
5046
5047         TOPBLOCK(cx);
5048         if (PL_scopestack_ix < inner)
5049             leave_scope(PL_scopestack[PL_scopestack_ix]);
5050         PL_curcop = cx->blk_oldcop;
5051
5052         return cx->blk_loop.my_op->op_nextop;
5053     }
5054     else
5055         RETURNOP(cx->blk_givwhen.leave_op);
5056 }
5057
5058 PP(pp_continue)
5059 {
5060     dVAR; dSP;
5061     I32 cxix;
5062     register PERL_CONTEXT *cx;
5063     I32 gimme;
5064     SV **newsp;
5065     PMOP *newpm;
5066
5067     PERL_UNUSED_VAR(gimme);
5068
5069     cxix = dopoptowhen(cxstack_ix);
5070     if (cxix < 0)
5071         DIE(aTHX_ "Can't \"continue\" outside a when block");
5072
5073     if (cxix < cxstack_ix)
5074         dounwind(cxix);
5075
5076     POPBLOCK(cx,newpm);
5077     assert(CxTYPE(cx) == CXt_WHEN);
5078
5079     SP = newsp;
5080     PL_curpm = newpm;   /* pop $1 et al */
5081
5082     LEAVE_with_name("when");
5083     RETURNOP(cx->blk_givwhen.leave_op->op_next);
5084 }
5085
5086 PP(pp_break)
5087 {
5088     dVAR;
5089     I32 cxix;
5090     register PERL_CONTEXT *cx;
5091
5092     cxix = dopoptogiven(cxstack_ix);
5093     if (cxix < 0)
5094         DIE(aTHX_ "Can't \"break\" outside a given block");
5095
5096     cx = &cxstack[cxix];
5097     if (CxFOREACH(cx))
5098         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5099
5100     if (cxix < cxstack_ix)
5101         dounwind(cxix);
5102
5103     /* Restore the sp at the time we entered the given block */
5104     TOPBLOCK(cx);
5105
5106     return cx->blk_givwhen.leave_op;
5107 }
5108
5109 static MAGIC *
5110 S_doparseform(pTHX_ SV *sv)
5111 {
5112     STRLEN len;
5113     register char *s = SvPV(sv, len);
5114     register char *send;
5115     register char *base = NULL; /* start of current field */
5116     register I32 skipspaces = 0; /* number of contiguous spaces seen */
5117     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5118     bool repeat    = FALSE; /* ~~ seen on this line */
5119     bool postspace = FALSE; /* a text field may need right padding */
5120     U32 *fops;
5121     register U32 *fpc;
5122     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5123     register I32 arg;
5124     bool ischop;            /* it's a ^ rather than a @ */
5125     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5126     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5127     MAGIC *mg = NULL;
5128     SV *sv_copy;
5129
5130     PERL_ARGS_ASSERT_DOPARSEFORM;
5131
5132     if (len == 0)
5133         Perl_croak(aTHX_ "Null picture in formline");
5134
5135     if (SvTYPE(sv) >= SVt_PVMG) {
5136         /* This might, of course, still return NULL.  */
5137         mg = mg_find(sv, PERL_MAGIC_fm);
5138     } else {
5139         sv_upgrade(sv, SVt_PVMG);
5140     }
5141
5142     if (mg) {
5143         /* still the same as previously-compiled string? */
5144         SV *old = mg->mg_obj;
5145         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5146               && len == SvCUR(old)
5147               && strnEQ(SvPVX(old), SvPVX(sv), len)
5148         ) {
5149             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5150             return mg;
5151         }
5152
5153         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5154         Safefree(mg->mg_ptr);
5155         mg->mg_ptr = NULL;
5156         SvREFCNT_dec(old);
5157         mg->mg_obj = NULL;
5158     }
5159     else {
5160         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5161         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5162     }
5163
5164     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5165     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5166     send = s + len;
5167
5168
5169     /* estimate the buffer size needed */
5170     for (base = s; s <= send; s++) {
5171         if (*s == '\n' || *s == '@' || *s == '^')
5172             maxops += 10;
5173     }
5174     s = base;
5175     base = NULL;
5176
5177     Newx(fops, maxops, U32);
5178     fpc = fops;
5179
5180     if (s < send) {
5181         linepc = fpc;
5182         *fpc++ = FF_LINEMARK;
5183         noblank = repeat = FALSE;
5184         base = s;
5185     }
5186
5187     while (s <= send) {
5188         switch (*s++) {
5189         default:
5190             skipspaces = 0;
5191             continue;
5192
5193         case '~':
5194             if (*s == '~') {
5195                 repeat = TRUE;
5196                 skipspaces++;
5197                 s++;
5198             }
5199             noblank = TRUE;
5200             /* FALL THROUGH */
5201         case ' ': case '\t':
5202             skipspaces++;
5203             continue;
5204         case 0:
5205             if (s < send) {
5206                 skipspaces = 0;
5207                 continue;
5208             } /* else FALL THROUGH */
5209         case '\n':
5210             arg = s - base;
5211             skipspaces++;
5212             arg -= skipspaces;
5213             if (arg) {
5214                 if (postspace)
5215                     *fpc++ = FF_SPACE;
5216                 *fpc++ = FF_LITERAL;
5217                 *fpc++ = (U32)arg;
5218             }
5219             postspace = FALSE;
5220             if (s <= send)
5221                 skipspaces--;
5222             if (skipspaces) {
5223                 *fpc++ = FF_SKIP;
5224                 *fpc++ = (U32)skipspaces;
5225             }
5226             skipspaces = 0;
5227             if (s <= send)
5228                 *fpc++ = FF_NEWLINE;
5229             if (noblank) {
5230                 *fpc++ = FF_BLANK;
5231                 if (repeat)
5232                     arg = fpc - linepc + 1;
5233                 else
5234                     arg = 0;
5235                 *fpc++ = (U32)arg;
5236             }
5237             if (s < send) {
5238                 linepc = fpc;
5239                 *fpc++ = FF_LINEMARK;
5240                 noblank = repeat = FALSE;
5241                 base = s;
5242             }
5243             else
5244                 s++;
5245             continue;
5246
5247         case '@':
5248         case '^':
5249             ischop = s[-1] == '^';
5250
5251             if (postspace) {
5252                 *fpc++ = FF_SPACE;
5253                 postspace = FALSE;
5254             }
5255             arg = (s - base) - 1;
5256             if (arg) {
5257                 *fpc++ = FF_LITERAL;
5258                 *fpc++ = (U32)arg;
5259             }
5260
5261             base = s - 1;
5262             *fpc++ = FF_FETCH;
5263             if (*s == '*') { /*  @* or ^*  */
5264                 s++;
5265                 *fpc++ = 2;  /* skip the @* or ^* */
5266                 if (ischop) {
5267                     *fpc++ = FF_LINESNGL;
5268                     *fpc++ = FF_CHOP;
5269                 } else
5270                     *fpc++ = FF_LINEGLOB;
5271             }
5272             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5273                 arg = ischop ? FORM_NUM_BLANK : 0;
5274                 base = s - 1;
5275                 while (*s == '#')
5276                     s++;
5277                 if (*s == '.') {
5278                     const char * const f = ++s;
5279                     while (*s == '#')
5280                         s++;
5281                     arg |= FORM_NUM_POINT + (s - f);
5282                 }
5283                 *fpc++ = s - base;              /* fieldsize for FETCH */
5284                 *fpc++ = FF_DECIMAL;
5285                 *fpc++ = (U32)arg;
5286                 unchopnum |= ! ischop;
5287             }
5288             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5289                 arg = ischop ? FORM_NUM_BLANK : 0;
5290                 base = s - 1;
5291                 s++;                                /* skip the '0' first */
5292                 while (*s == '#')
5293                     s++;
5294                 if (*s == '.') {
5295                     const char * const f = ++s;
5296                     while (*s == '#')
5297                         s++;
5298                     arg |= FORM_NUM_POINT + (s - f);
5299                 }
5300                 *fpc++ = s - base;                /* fieldsize for FETCH */
5301                 *fpc++ = FF_0DECIMAL;
5302                 *fpc++ = (U32)arg;
5303                 unchopnum |= ! ischop;
5304             }
5305             else {                              /* text field */
5306                 I32 prespace = 0;
5307                 bool ismore = FALSE;
5308
5309                 if (*s == '>') {
5310                     while (*++s == '>') ;
5311                     prespace = FF_SPACE;
5312                 }
5313                 else if (*s == '|') {
5314                     while (*++s == '|') ;
5315                     prespace = FF_HALFSPACE;
5316                     postspace = TRUE;
5317                 }
5318                 else {
5319                     if (*s == '<')
5320                         while (*++s == '<') ;
5321                     postspace = TRUE;
5322                 }
5323                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5324                     s += 3;
5325                     ismore = TRUE;
5326                 }
5327                 *fpc++ = s - base;              /* fieldsize for FETCH */
5328
5329                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5330
5331                 if (prespace)
5332                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5333                 *fpc++ = FF_ITEM;
5334                 if (ismore)
5335                     *fpc++ = FF_MORE;
5336                 if (ischop)
5337                     *fpc++ = FF_CHOP;
5338             }
5339             base = s;
5340             skipspaces = 0;
5341             continue;
5342         }
5343     }
5344     *fpc++ = FF_END;
5345
5346     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5347     arg = fpc - fops;
5348
5349     mg->mg_ptr = (char *) fops;
5350     mg->mg_len = arg * sizeof(U32);
5351     mg->mg_obj = sv_copy;
5352     mg->mg_flags |= MGf_REFCOUNTED;
5353
5354     if (unchopnum && repeat)
5355         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5356
5357     return mg;
5358 }
5359
5360
5361 STATIC bool
5362 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5363 {
5364     /* Can value be printed in fldsize chars, using %*.*f ? */
5365     NV pwr = 1;
5366     NV eps = 0.5;
5367     bool res = FALSE;
5368     int intsize = fldsize - (value < 0 ? 1 : 0);
5369
5370     if (frcsize & FORM_NUM_POINT)
5371         intsize--;
5372     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5373     intsize -= frcsize;
5374
5375     while (intsize--) pwr *= 10.0;
5376     while (frcsize--) eps /= 10.0;
5377
5378     if( value >= 0 ){
5379         if (value + eps >= pwr)
5380             res = TRUE;
5381     } else {
5382         if (value - eps <= -pwr)
5383             res = TRUE;
5384     }
5385     return res;
5386 }
5387
5388 static I32
5389 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5390 {
5391     dVAR;
5392     SV * const datasv = FILTER_DATA(idx);
5393     const int filter_has_file = IoLINES(datasv);
5394     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5395     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5396     int status = 0;
5397     SV *upstream;
5398     STRLEN got_len;
5399     char *got_p = NULL;
5400     char *prune_from = NULL;
5401     bool read_from_cache = FALSE;
5402     STRLEN umaxlen;
5403
5404     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5405
5406     assert(maxlen >= 0);
5407     umaxlen = maxlen;
5408
5409     /* I was having segfault trouble under Linux 2.2.5 after a
5410        parse error occured.  (Had to hack around it with a test
5411        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5412        not sure where the trouble is yet.  XXX */
5413
5414     {
5415         SV *const cache = datasv;
5416         if (SvOK(cache)) {
5417             STRLEN cache_len;
5418             const char *cache_p = SvPV(cache, cache_len);
5419             STRLEN take = 0;
5420
5421             if (umaxlen) {
5422                 /* Running in block mode and we have some cached data already.
5423                  */
5424                 if (cache_len >= umaxlen) {
5425                     /* In fact, so much data we don't even need to call
5426                        filter_read.  */
5427                     take = umaxlen;
5428                 }
5429             } else {
5430                 const char *const first_nl =
5431                     (const char *)memchr(cache_p, '\n', cache_len);
5432                 if (first_nl) {
5433                     take = first_nl + 1 - cache_p;
5434                 }
5435             }
5436             if (take) {
5437                 sv_catpvn(buf_sv, cache_p, take);
5438                 sv_chop(cache, cache_p + take);
5439                 /* Definitely not EOF  */
5440                 return 1;
5441             }
5442
5443             sv_catsv(buf_sv, cache);
5444             if (umaxlen) {
5445                 umaxlen -= cache_len;
5446             }
5447             SvOK_off(cache);
5448             read_from_cache = TRUE;
5449         }
5450     }
5451
5452     /* Filter API says that the filter appends to the contents of the buffer.
5453        Usually the buffer is "", so the details don't matter. But if it's not,
5454        then clearly what it contains is already filtered by this filter, so we
5455        don't want to pass it in a second time.
5456        I'm going to use a mortal in case the upstream filter croaks.  */
5457     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5458         ? sv_newmortal() : buf_sv;
5459     SvUPGRADE(upstream, SVt_PV);
5460
5461     if (filter_has_file) {
5462         status = FILTER_READ(idx+1, upstream, 0);
5463     }
5464
5465     if (filter_sub && status >= 0) {
5466         dSP;
5467         int count;
5468
5469         ENTER_with_name("call_filter_sub");
5470         save_gp(PL_defgv, 0);
5471         GvINTRO_off(PL_defgv);
5472         SAVEGENERICSV(GvSV(PL_defgv));
5473         SAVETMPS;
5474         EXTEND(SP, 2);
5475
5476         DEFSV_set(upstream);
5477         SvREFCNT_inc_simple_void_NN(upstream);
5478         PUSHMARK(SP);
5479         mPUSHi(0);
5480         if (filter_state) {
5481             PUSHs(filter_state);
5482         }
5483         PUTBACK;
5484         count = call_sv(filter_sub, G_SCALAR);
5485         SPAGAIN;
5486
5487         if (count > 0) {
5488             SV *out = POPs;
5489             if (SvOK(out)) {
5490                 status = SvIV(out);
5491             }
5492         }
5493
5494         PUTBACK;
5495         FREETMPS;
5496         LEAVE_with_name("call_filter_sub");
5497     }
5498
5499     if(SvOK(upstream)) {
5500         got_p = SvPV(upstream, got_len);
5501         if (umaxlen) {
5502             if (got_len > umaxlen) {
5503                 prune_from = got_p + umaxlen;
5504             }
5505         } else {
5506             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5507             if (first_nl && first_nl + 1 < got_p + got_len) {
5508                 /* There's a second line here... */
5509                 prune_from = first_nl + 1;
5510             }
5511         }
5512     }
5513     if (prune_from) {
5514         /* Oh. Too long. Stuff some in our cache.  */
5515         STRLEN cached_len = got_p + got_len - prune_from;
5516         SV *const cache = datasv;
5517
5518         if (SvOK(cache)) {
5519             /* Cache should be empty.  */
5520             assert(!SvCUR(cache));
5521         }
5522
5523         sv_setpvn(cache, prune_from, cached_len);
5524         /* If you ask for block mode, you may well split UTF-8 characters.
5525            "If it breaks, you get to keep both parts"
5526            (Your code is broken if you  don't put them back together again
5527            before something notices.) */
5528         if (SvUTF8(upstream)) {
5529             SvUTF8_on(cache);
5530         }
5531         SvCUR_set(upstream, got_len - cached_len);
5532         *prune_from = 0;
5533         /* Can't yet be EOF  */
5534         if (status == 0)
5535             status = 1;
5536     }
5537
5538     /* If they are at EOF but buf_sv has something in it, then they may never
5539        have touched the SV upstream, so it may be undefined.  If we naively
5540        concatenate it then we get a warning about use of uninitialised value.
5541     */
5542     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5543         sv_catsv(buf_sv, upstream);
5544     }
5545
5546     if (status <= 0) {
5547         IoLINES(datasv) = 0;
5548         if (filter_state) {
5549             SvREFCNT_dec(filter_state);
5550             IoTOP_GV(datasv) = NULL;
5551         }
5552         if (filter_sub) {
5553             SvREFCNT_dec(filter_sub);
5554             IoBOTTOM_GV(datasv) = NULL;
5555         }
5556         filter_del(S_run_user_filter);
5557     }
5558     if (status == 0 && read_from_cache) {
5559         /* If we read some data from the cache (and by getting here it implies
5560            that we emptied the cache) then we aren't yet at EOF, and mustn't
5561            report that to our caller.  */
5562         return 1;
5563     }
5564     return status;
5565 }
5566
5567 /* perhaps someone can come up with a better name for
5568    this?  it is not really "absolute", per se ... */
5569 static bool
5570 S_path_is_absolute(const char *name)
5571 {
5572     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5573
5574     if (PERL_FILE_IS_ABSOLUTE(name)
5575 #ifdef WIN32
5576         || (*name == '.' && ((name[1] == '/' ||
5577                              (name[1] == '.' && name[2] == '/'))
5578                          || (name[1] == '\\' ||
5579                              ( name[1] == '.' && name[2] == '\\')))
5580             )
5581 #else
5582         || (*name == '.' && (name[1] == '/' ||
5583                              (name[1] == '.' && name[2] == '/')))
5584 #endif
5585          )
5586     {
5587         return TRUE;
5588     }
5589     else
5590         return FALSE;
5591 }
5592
5593 /*
5594  * Local variables:
5595  * c-indentation-style: bsd
5596  * c-basic-offset: 4
5597  * indent-tabs-mode: t
5598  * End:
5599  *
5600  * ex: set ts=8 sts=4 sw=4 noet:
5601  */