pp_ctl.c

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