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