pp_ctl.c

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