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