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