pp_ctl.c

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