pp_ctl.c

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