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 PP(pp_enteriter)
2054 {
2055     dVAR; dSP; dMARK;
2056     register PERL_CONTEXT *cx;
2057     const I32 gimme = GIMME_V;
2058     void *itervar; /* location of the iteration variable */
2059     U8 cxtype = CXt_LOOP_FOR;
2060
2061     ENTER_with_name("loop1");
2062     SAVETMPS;
2063
2064     if (PL_op->op_targ) {                        /* "my" variable */
2065         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2066             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2067             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2068                     SVs_PADSTALE, SVs_PADSTALE);
2069         }
2070         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2071 #ifdef USE_ITHREADS
2072         itervar = PL_comppad;
2073 #else
2074         itervar = &PAD_SVl(PL_op->op_targ);
2075 #endif
2076     }
2077     else {                                      /* symbol table variable */
2078         GV * const gv = MUTABLE_GV(POPs);
2079         SV** svp = &GvSV(gv);
2080         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2081         *svp = newSV(0);
2082         itervar = (void *)gv;
2083     }
2084
2085     if (PL_op->op_private & OPpITER_DEF)
2086         cxtype |= CXp_FOR_DEF;
2087
2088     ENTER_with_name("loop2");
2089
2090     PUSHBLOCK(cx, cxtype, SP);
2091     PUSHLOOP_FOR(cx, itervar, MARK);
2092     if (PL_op->op_flags & OPf_STACKED) {
2093         SV *maybe_ary = POPs;
2094         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2095             dPOPss;
2096             SV * const right = maybe_ary;
2097             SvGETMAGIC(sv);
2098             SvGETMAGIC(right);
2099             if (RANGE_IS_NUMERIC(sv,right)) {
2100                 cx->cx_type &= ~CXTYPEMASK;
2101                 cx->cx_type |= CXt_LOOP_LAZYIV;
2102                 /* Make sure that no-one re-orders cop.h and breaks our
2103                    assumptions */
2104                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2105 #ifdef NV_PRESERVES_UV
2106                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2107                                   (SvNV(sv) > (NV)IV_MAX)))
2108                         ||
2109                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2110                                      (SvNV(right) < (NV)IV_MIN))))
2111 #else
2112                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2113                                   ||
2114                                   ((SvNV(sv) > 0) &&
2115                                         ((SvUV(sv) > (UV)IV_MAX) ||
2116                                          (SvNV(sv) > (NV)UV_MAX)))))
2117                         ||
2118                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2119                                      ||
2120                                      ((SvNV(right) > 0) &&
2121                                         ((SvUV(right) > (UV)IV_MAX) ||
2122                                          (SvNV(right) > (NV)UV_MAX))))))
2123 #endif
2124                     DIE(aTHX_ "Range iterator outside integer range");
2125                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2126                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2127 #ifdef DEBUGGING
2128                 /* for correct -Dstv display */
2129                 cx->blk_oldsp = sp - PL_stack_base;
2130 #endif
2131             }
2132             else {
2133                 cx->cx_type &= ~CXTYPEMASK;
2134                 cx->cx_type |= CXt_LOOP_LAZYSV;
2135                 /* Make sure that no-one re-orders cop.h and breaks our
2136                    assumptions */
2137                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2138                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2139                 cx->blk_loop.state_u.lazysv.end = right;
2140                 SvREFCNT_inc(right);
2141                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2142                 /* This will do the upgrade to SVt_PV, and warn if the value
2143                    is uninitialised.  */
2144                 (void) SvPV_nolen_const(right);
2145                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2146                    to replace !SvOK() with a pointer to "".  */
2147                 if (!SvOK(right)) {
2148                     SvREFCNT_dec(right);
2149                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2150                 }
2151             }
2152         }
2153         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2154             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2155             SvREFCNT_inc(maybe_ary);
2156             cx->blk_loop.state_u.ary.ix =
2157                 (PL_op->op_private & OPpITER_REVERSED) ?
2158                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2159                 -1;
2160         }
2161     }
2162     else { /* iterating over items on the stack */
2163         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2164         if (PL_op->op_private & OPpITER_REVERSED) {
2165             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2166         }
2167         else {
2168             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2169         }
2170     }
2171
2172     RETURN;
2173 }
2174
2175 PP(pp_enterloop)
2176 {
2177     dVAR; dSP;
2178     register PERL_CONTEXT *cx;
2179     const I32 gimme = GIMME_V;
2180
2181     ENTER_with_name("loop1");
2182     SAVETMPS;
2183     ENTER_with_name("loop2");
2184
2185     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2186     PUSHLOOP_PLAIN(cx, SP);
2187
2188     RETURN;
2189 }
2190
2191 PP(pp_leaveloop)
2192 {
2193     dVAR; dSP;
2194     register PERL_CONTEXT *cx;
2195     I32 gimme;
2196     SV **newsp;
2197     PMOP *newpm;
2198     SV **mark;
2199
2200     POPBLOCK(cx,newpm);
2201     assert(CxTYPE_is_LOOP(cx));
2202     mark = newsp;
2203     newsp = PL_stack_base + cx->blk_loop.resetsp;
2204
2205     TAINT_NOT;
2206     if (gimme == G_VOID)
2207         NOOP;
2208     else if (gimme == G_SCALAR) {
2209         if (mark < SP)
2210             *++newsp = sv_mortalcopy(*SP);
2211         else
2212             *++newsp = &PL_sv_undef;
2213     }
2214     else {
2215         while (mark < SP) {
2216             *++newsp = sv_mortalcopy(*++mark);
2217             TAINT_NOT;          /* Each item is independent */
2218         }
2219     }
2220     SP = newsp;
2221     PUTBACK;
2222
2223     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2224     PL_curpm = newpm;   /* ... and pop $1 et al */
2225
2226     LEAVE_with_name("loop2");
2227     LEAVE_with_name("loop1");
2228
2229     return NORMAL;
2230 }
2231
2232 STATIC void
2233 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2234                        PERL_CONTEXT *cx, PMOP *newpm)
2235 {
2236     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2237     if (gimme == G_SCALAR) {
2238         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2239             SV *sv;
2240             if (MARK < SP) {
2241                 assert(MARK+1 == SP);
2242                 if ((SvPADTMP(TOPs) ||
2243                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2244                        == SVf_READONLY
2245                     ) &&
2246                     !SvSMAGICAL(TOPs)) {
2247                     LEAVE;
2248                     cxstack_ix--;
2249                     POPSUB(cx,sv);
2250                     PL_curpm = newpm;
2251                     LEAVESUB(sv);
2252                     Perl_croak(aTHX_
2253                         "Can't return %s from lvalue subroutine",
2254                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2255                         : "a readonly value" : "a temporary");
2256                 }
2257                 else {                  /* Can be a localized value
2258                     EXTEND_MORTAL(1);    * subject to deletion. */
2259                     PL_tmps_stack[++PL_tmps_ix] = *SP;
2260                     SvREFCNT_inc_void(*SP);
2261                     *++newsp = *SP;
2262                 }
2263             }
2264             else {
2265                 /* sub:lvalue{} will take us here. */
2266                 LEAVE;
2267                 cxstack_ix--;
2268                 POPSUB(cx,sv);
2269                 PL_curpm = newpm;
2270                 LEAVESUB(sv);
2271                 Perl_croak(aTHX_
2272                 /* diag_listed_as: Can't return %s from lvalue subroutine*/
2273                           "Can't return undef from lvalue subroutine"
2274                 );
2275             }
2276         }
2277         else if (MARK < SP) {
2278                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2279                         *++newsp = SvREFCNT_inc(*SP);
2280                         FREETMPS;
2281                         sv_2mortal(*newsp);
2282                 }
2283                 else
2284                     *++newsp =
2285                         !SvTEMP(*SP)
2286                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2287                           : *SP;
2288         }
2289         else {
2290             EXTEND(newsp,1);
2291             *++newsp = &PL_sv_undef;
2292         }
2293         if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2294             SvGETMAGIC(TOPs);
2295             if (!SvOK(TOPs)) {
2296                 U8 deref_type;
2297                 if (cx->blk_sub.retop->op_type == OP_RV2SV)
2298                     deref_type = OPpDEREF_SV;
2299                 else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2300                     deref_type = OPpDEREF_AV;
2301                 else {
2302                     assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2303                     deref_type = OPpDEREF_HV;
2304                 }
2305                 vivify_ref(TOPs, deref_type);
2306             }
2307         }
2308     }
2309     else if (gimme == G_ARRAY) {
2310         assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF));
2311         if (ref || !CxLVAL(cx))
2312             while (++MARK <= SP)
2313                 *++newsp =
2314                      SvTEMP(*MARK)
2315                        ? *MARK
2316                        : ref && SvFLAGS(*MARK) & SVs_PADTMP
2317                            ? sv_mortalcopy(*MARK)
2318                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2319         else while (++MARK <= SP) {
2320             if (*MARK != &PL_sv_undef
2321                     && (SvPADTMP(*MARK)
2322                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2323                              == SVf_READONLY
2324                        )
2325             ) {
2326                     SV *sv;
2327                     /* Might be flattened array after $#array =  */
2328                     PUTBACK;
2329                     LEAVE;
2330                     cxstack_ix--;
2331                     POPSUB(cx,sv);
2332                     PL_curpm = newpm;
2333                     LEAVESUB(sv);
2334                     Perl_croak(aTHX_
2335                         "Can't return a %s from lvalue subroutine",
2336                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2337             }
2338             else
2339                 *++newsp =
2340                     SvTEMP(*MARK)
2341                        ? *MARK
2342                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2343         }
2344     }
2345     PL_stack_sp = newsp;
2346 }
2347
2348 PP(pp_return)
2349 {
2350     dVAR; dSP; dMARK;
2351     register PERL_CONTEXT *cx;
2352     bool popsub2 = FALSE;
2353     bool clear_errsv = FALSE;
2354     bool lval = FALSE;
2355     bool gmagic = FALSE;
2356     I32 gimme;
2357     SV **newsp;
2358     PMOP *newpm;
2359     I32 optype = 0;
2360     SV *namesv;
2361     SV *sv;
2362     OP *retop = NULL;
2363
2364     const I32 cxix = dopoptosub(cxstack_ix);
2365
2366     if (cxix < 0) {
2367         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2368                                      * sort block, which is a CXt_NULL
2369                                      * not a CXt_SUB */
2370             dounwind(0);
2371             PL_stack_base[1] = *PL_stack_sp;
2372             PL_stack_sp = PL_stack_base + 1;
2373             return 0;
2374         }
2375         else
2376             DIE(aTHX_ "Can't return outside a subroutine");
2377     }
2378     if (cxix < cxstack_ix)
2379         dounwind(cxix);
2380
2381     if (CxMULTICALL(&cxstack[cxix])) {
2382         gimme = cxstack[cxix].blk_gimme;
2383         if (gimme == G_VOID)
2384             PL_stack_sp = PL_stack_base;
2385         else if (gimme == G_SCALAR) {
2386             PL_stack_base[1] = *PL_stack_sp;
2387             PL_stack_sp = PL_stack_base + 1;
2388         }
2389         return 0;
2390     }
2391
2392     POPBLOCK(cx,newpm);
2393     switch (CxTYPE(cx)) {
2394     case CXt_SUB:
2395         popsub2 = TRUE;
2396         lval = !!CvLVALUE(cx->blk_sub.cv);
2397         retop = cx->blk_sub.retop;
2398         gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
2399         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2400         break;
2401     case CXt_EVAL:
2402         if (!(PL_in_eval & EVAL_KEEPERR))
2403             clear_errsv = TRUE;
2404         POPEVAL(cx);
2405         namesv = cx->blk_eval.old_namesv;
2406         retop = cx->blk_eval.retop;
2407         if (CxTRYBLOCK(cx))
2408             break;
2409         if (optype == OP_REQUIRE &&
2410             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2411         {
2412             /* Unassume the success we assumed earlier. */
2413             (void)hv_delete(GvHVn(PL_incgv),
2414                             SvPVX_const(namesv), SvCUR(namesv),
2415                             G_DISCARD);
2416             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2417         }
2418         break;
2419     case CXt_FORMAT:
2420         POPFORMAT(cx);
2421         retop = cx->blk_sub.retop;
2422         break;
2423     default:
2424         DIE(aTHX_ "panic: return");
2425     }
2426
2427     TAINT_NOT;
2428     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2429     else {
2430       if (gimme == G_SCALAR) {
2431         if (MARK < SP) {
2432             if (popsub2) {
2433                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2434                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2435                         *++newsp = SvREFCNT_inc(*SP);
2436                         FREETMPS;
2437                         sv_2mortal(*newsp);
2438                     }
2439                     else {
2440                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2441                         FREETMPS;
2442                         *++newsp = sv_mortalcopy(sv);
2443                         SvREFCNT_dec(sv);
2444                         if (gmagic) SvGETMAGIC(sv);
2445                     }
2446                 }
2447                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
2448                     *++newsp = *SP;
2449                     if (gmagic) SvGETMAGIC(*SP);
2450                 }
2451                 else
2452                     *++newsp = sv_mortalcopy(*SP);
2453             }
2454             else
2455                 *++newsp = sv_mortalcopy(*SP);
2456         }
2457         else
2458             *++newsp = &PL_sv_undef;
2459       }
2460       else if (gimme == G_ARRAY) {
2461         while (++MARK <= SP) {
2462             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2463                         ? *MARK : sv_mortalcopy(*MARK);
2464             TAINT_NOT;          /* Each item is independent */
2465         }
2466       }
2467       PL_stack_sp = newsp;
2468     }
2469
2470     LEAVE;
2471     /* Stack values are safe: */
2472     if (popsub2) {
2473         cxstack_ix--;
2474         POPSUB(cx,sv);  /* release CV and @_ ... */
2475     }
2476     else
2477         sv = NULL;
2478     PL_curpm = newpm;   /* ... and pop $1 et al */
2479
2480     LEAVESUB(sv);
2481     if (clear_errsv) {
2482         CLEAR_ERRSV();
2483     }
2484     return retop;
2485 }
2486
2487 /* This duplicates parts of pp_leavesub, so that it can share code with
2488  * pp_return */
2489 PP(pp_leavesublv)
2490 {
2491     dVAR; dSP;
2492     SV **newsp;
2493     PMOP *newpm;
2494     I32 gimme;
2495     register PERL_CONTEXT *cx;
2496     SV *sv;
2497
2498     if (CxMULTICALL(&cxstack[cxstack_ix]))
2499         return 0;
2500
2501     POPBLOCK(cx,newpm);
2502     cxstack_ix++; /* temporarily protect top context */
2503     assert(CvLVALUE(cx->blk_sub.cv));
2504
2505     TAINT_NOT;
2506
2507     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2508
2509     LEAVE;
2510     cxstack_ix--;
2511     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2512     PL_curpm = newpm;   /* ... and pop $1 et al */
2513
2514     LEAVESUB(sv);
2515     return cx->blk_sub.retop;
2516 }
2517
2518 PP(pp_last)
2519 {
2520     dVAR; dSP;
2521     I32 cxix;
2522     register PERL_CONTEXT *cx;
2523     I32 pop2 = 0;
2524     I32 gimme;
2525     I32 optype;
2526     OP *nextop = NULL;
2527     SV **newsp;
2528     PMOP *newpm;
2529     SV **mark;
2530     SV *sv = NULL;
2531
2532
2533     if (PL_op->op_flags & OPf_SPECIAL) {
2534         cxix = dopoptoloop(cxstack_ix);
2535         if (cxix < 0)
2536             DIE(aTHX_ "Can't \"last\" outside a loop block");
2537     }
2538     else {
2539         cxix = dopoptolabel(cPVOP->op_pv);
2540         if (cxix < 0)
2541             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2542     }
2543     if (cxix < cxstack_ix)
2544         dounwind(cxix);
2545
2546     POPBLOCK(cx,newpm);
2547     cxstack_ix++; /* temporarily protect top context */
2548     mark = newsp;
2549     switch (CxTYPE(cx)) {
2550     case CXt_LOOP_LAZYIV:
2551     case CXt_LOOP_LAZYSV:
2552     case CXt_LOOP_FOR:
2553     case CXt_LOOP_PLAIN:
2554         pop2 = CxTYPE(cx);
2555         newsp = PL_stack_base + cx->blk_loop.resetsp;
2556         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2557         break;
2558     case CXt_SUB:
2559         pop2 = CXt_SUB;
2560         nextop = cx->blk_sub.retop;
2561         break;
2562     case CXt_EVAL:
2563         POPEVAL(cx);
2564         nextop = cx->blk_eval.retop;
2565         break;
2566     case CXt_FORMAT:
2567         POPFORMAT(cx);
2568         nextop = cx->blk_sub.retop;
2569         break;
2570     default:
2571         DIE(aTHX_ "panic: last");
2572     }
2573
2574     TAINT_NOT;
2575     if (gimme == G_SCALAR) {
2576         if (MARK < SP)
2577             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2578                         ? *SP : sv_mortalcopy(*SP);
2579         else
2580             *++newsp = &PL_sv_undef;
2581     }
2582     else if (gimme == G_ARRAY) {
2583         while (++MARK <= SP) {
2584             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2585                         ? *MARK : sv_mortalcopy(*MARK);
2586             TAINT_NOT;          /* Each item is independent */
2587         }
2588     }
2589     SP = newsp;
2590     PUTBACK;
2591
2592     LEAVE;
2593     cxstack_ix--;
2594     /* Stack values are safe: */
2595     switch (pop2) {
2596     case CXt_LOOP_LAZYIV:
2597     case CXt_LOOP_PLAIN:
2598     case CXt_LOOP_LAZYSV:
2599     case CXt_LOOP_FOR:
2600         POPLOOP(cx);    /* release loop vars ... */
2601         LEAVE;
2602         break;
2603     case CXt_SUB:
2604         POPSUB(cx,sv);  /* release CV and @_ ... */
2605         break;
2606     }
2607     PL_curpm = newpm;   /* ... and pop $1 et al */
2608
2609     LEAVESUB(sv);
2610     PERL_UNUSED_VAR(optype);
2611     PERL_UNUSED_VAR(gimme);
2612     return nextop;
2613 }
2614
2615 PP(pp_next)
2616 {
2617     dVAR;
2618     I32 cxix;
2619     register PERL_CONTEXT *cx;
2620     I32 inner;
2621
2622     if (PL_op->op_flags & OPf_SPECIAL) {
2623         cxix = dopoptoloop(cxstack_ix);
2624         if (cxix < 0)
2625             DIE(aTHX_ "Can't \"next\" outside a loop block");
2626     }
2627     else {
2628         cxix = dopoptolabel(cPVOP->op_pv);
2629         if (cxix < 0)
2630             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2631     }
2632     if (cxix < cxstack_ix)
2633         dounwind(cxix);
2634
2635     /* clear off anything above the scope we're re-entering, but
2636      * save the rest until after a possible continue block */
2637     inner = PL_scopestack_ix;
2638     TOPBLOCK(cx);
2639     if (PL_scopestack_ix < inner)
2640         leave_scope(PL_scopestack[PL_scopestack_ix]);
2641     PL_curcop = cx->blk_oldcop;
2642     return (cx)->blk_loop.my_op->op_nextop;
2643 }
2644
2645 PP(pp_redo)
2646 {
2647     dVAR;
2648     I32 cxix;
2649     register PERL_CONTEXT *cx;
2650     I32 oldsave;
2651     OP* redo_op;
2652
2653     if (PL_op->op_flags & OPf_SPECIAL) {
2654         cxix = dopoptoloop(cxstack_ix);
2655         if (cxix < 0)
2656             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2657     }
2658     else {
2659         cxix = dopoptolabel(cPVOP->op_pv);
2660         if (cxix < 0)
2661             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2662     }
2663     if (cxix < cxstack_ix)
2664         dounwind(cxix);
2665
2666     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2667     if (redo_op->op_type == OP_ENTER) {
2668         /* pop one less context to avoid $x being freed in while (my $x..) */
2669         cxstack_ix++;
2670         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2671         redo_op = redo_op->op_next;
2672     }
2673
2674     TOPBLOCK(cx);
2675     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2676     LEAVE_SCOPE(oldsave);
2677     FREETMPS;
2678     PL_curcop = cx->blk_oldcop;
2679     return redo_op;
2680 }
2681
2682 STATIC OP *
2683 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2684 {
2685     dVAR;
2686     OP **ops = opstack;
2687     static const char too_deep[] = "Target of goto is too deeply nested";
2688
2689     PERL_ARGS_ASSERT_DOFINDLABEL;
2690
2691     if (ops >= oplimit)
2692         Perl_croak(aTHX_ too_deep);
2693     if (o->op_type == OP_LEAVE ||
2694         o->op_type == OP_SCOPE ||
2695         o->op_type == OP_LEAVELOOP ||
2696         o->op_type == OP_LEAVESUB ||
2697         o->op_type == OP_LEAVETRY)
2698     {
2699         *ops++ = cUNOPo->op_first;
2700         if (ops >= oplimit)
2701             Perl_croak(aTHX_ too_deep);
2702     }
2703     *ops = 0;
2704     if (o->op_flags & OPf_KIDS) {
2705         OP *kid;
2706         /* First try all the kids at this level, since that's likeliest. */
2707         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2708             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2709                 const char *kid_label = CopLABEL(kCOP);
2710                 if (kid_label && strEQ(kid_label, label))
2711                     return kid;
2712             }
2713         }
2714         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2715             if (kid == PL_lastgotoprobe)
2716                 continue;
2717             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2718                 if (ops == opstack)
2719                     *ops++ = kid;
2720                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2721                          ops[-1]->op_type == OP_DBSTATE)
2722                     ops[-1] = kid;
2723                 else
2724                     *ops++ = kid;
2725             }
2726             if ((o = dofindlabel(kid, label, ops, oplimit)))
2727                 return o;
2728         }
2729     }
2730     *ops = 0;
2731     return 0;
2732 }
2733
2734 PP(pp_goto)
2735 {
2736     dVAR; dSP;
2737     OP *retop = NULL;
2738     I32 ix;
2739     register PERL_CONTEXT *cx;
2740 #define GOTO_DEPTH 64
2741     OP *enterops[GOTO_DEPTH];
2742     const char *label = NULL;
2743     const bool do_dump = (PL_op->op_type == OP_DUMP);
2744     static const char must_have_label[] = "goto must have label";
2745
2746     if (PL_op->op_flags & OPf_STACKED) {
2747         SV * const sv = POPs;
2748
2749         /* This egregious kludge implements goto &subroutine */
2750         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2751             I32 cxix;
2752             register PERL_CONTEXT *cx;
2753             CV *cv = MUTABLE_CV(SvRV(sv));
2754             SV** mark;
2755             I32 items = 0;
2756             I32 oldsave;
2757             bool reified = 0;
2758
2759         retry:
2760             if (!CvROOT(cv) && !CvXSUB(cv)) {
2761                 const GV * const gv = CvGV(cv);
2762                 if (gv) {
2763                     GV *autogv;
2764                     SV *tmpstr;
2765                     /* autoloaded stub? */
2766                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2767                         goto retry;
2768                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2769                                           GvNAMELEN(gv), FALSE);
2770                     if (autogv && (cv = GvCV(autogv)))
2771                         goto retry;
2772                     tmpstr = sv_newmortal();
2773                     gv_efullname3(tmpstr, gv, NULL);
2774                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2775                 }
2776                 DIE(aTHX_ "Goto undefined subroutine");
2777             }
2778
2779             /* First do some returnish stuff. */
2780             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2781             FREETMPS;
2782             cxix = dopoptosub(cxstack_ix);
2783             if (cxix < 0)
2784                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2785             if (cxix < cxstack_ix)
2786                 dounwind(cxix);
2787             TOPBLOCK(cx);
2788             SPAGAIN;
2789             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2790             if (CxTYPE(cx) == CXt_EVAL) {
2791                 if (CxREALEVAL(cx))
2792                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2793                 else
2794                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2795             }
2796             else if (CxMULTICALL(cx))
2797                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2798             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2799                 /* put @_ back onto stack */
2800                 AV* av = cx->blk_sub.argarray;
2801
2802                 items = AvFILLp(av) + 1;
2803                 EXTEND(SP, items+1); /* @_ could have been extended. */
2804                 Copy(AvARRAY(av), SP + 1, items, SV*);
2805                 SvREFCNT_dec(GvAV(PL_defgv));
2806                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2807                 CLEAR_ARGARRAY(av);
2808                 /* abandon @_ if it got reified */
2809                 if (AvREAL(av)) {
2810                     reified = 1;
2811                     SvREFCNT_dec(av);
2812                     av = newAV();
2813                     av_extend(av, items-1);
2814                     AvREIFY_only(av);
2815                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2816                 }
2817             }
2818             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2819                 AV* const av = GvAV(PL_defgv);
2820                 items = AvFILLp(av) + 1;
2821                 EXTEND(SP, items+1); /* @_ could have been extended. */
2822                 Copy(AvARRAY(av), SP + 1, items, SV*);
2823             }
2824             mark = SP;
2825             SP += items;
2826             if (CxTYPE(cx) == CXt_SUB &&
2827                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2828                 SvREFCNT_dec(cx->blk_sub.cv);
2829             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2830             LEAVE_SCOPE(oldsave);
2831
2832             /* Now do some callish stuff. */
2833             SAVETMPS;
2834             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2835             if (CvISXSUB(cv)) {
2836                 OP* const retop = cx->blk_sub.retop;
2837                 SV **newsp __attribute__unused__;
2838                 I32 gimme __attribute__unused__;
2839                 if (reified) {
2840                     I32 index;
2841                     for (index=0; index<items; index++)
2842                         sv_2mortal(SP[-index]);
2843                 }
2844
2845                 /* XS subs don't have a CxSUB, so pop it */
2846                 POPBLOCK(cx, PL_curpm);
2847                 /* Push a mark for the start of arglist */
2848                 PUSHMARK(mark);
2849                 PUTBACK;
2850                 (void)(*CvXSUB(cv))(aTHX_ cv);
2851                 LEAVE;
2852                 return retop;
2853             }
2854             else {
2855                 AV* const padlist = CvPADLIST(cv);
2856                 if (CxTYPE(cx) == CXt_EVAL) {
2857                     PL_in_eval = CxOLD_IN_EVAL(cx);
2858                     PL_eval_root = cx->blk_eval.old_eval_root;
2859                     cx->cx_type = CXt_SUB;
2860                 }
2861                 cx->blk_sub.cv = cv;
2862                 cx->blk_sub.olddepth = CvDEPTH(cv);
2863
2864                 CvDEPTH(cv)++;
2865                 if (CvDEPTH(cv) < 2)
2866                     SvREFCNT_inc_simple_void_NN(cv);
2867                 else {
2868                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2869                         sub_crush_depth(cv);
2870                     pad_push(padlist, CvDEPTH(cv));
2871                 }
2872                 SAVECOMPPAD();
2873                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2874                 if (CxHASARGS(cx))
2875                 {
2876                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2877
2878                     cx->blk_sub.savearray = GvAV(PL_defgv);
2879                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2880                     CX_CURPAD_SAVE(cx->blk_sub);
2881                     cx->blk_sub.argarray = av;
2882
2883                     if (items >= AvMAX(av) + 1) {
2884                         SV **ary = AvALLOC(av);
2885                         if (AvARRAY(av) != ary) {
2886                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2887                             AvARRAY(av) = ary;
2888                         }
2889                         if (items >= AvMAX(av) + 1) {
2890                             AvMAX(av) = items - 1;
2891                             Renew(ary,items+1,SV*);
2892                             AvALLOC(av) = ary;
2893                             AvARRAY(av) = ary;
2894                         }
2895                     }
2896                     ++mark;
2897                     Copy(mark,AvARRAY(av),items,SV*);
2898                     AvFILLp(av) = items - 1;
2899                     assert(!AvREAL(av));
2900                     if (reified) {
2901                         /* transfer 'ownership' of refcnts to new @_ */
2902                         AvREAL_on(av);
2903                         AvREIFY_off(av);
2904                     }
2905                     while (items--) {
2906                         if (*mark)
2907                             SvTEMP_off(*mark);
2908                         mark++;
2909                     }
2910                 }
2911                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2912                     Perl_get_db_sub(aTHX_ NULL, cv);
2913                     if (PERLDB_GOTO) {
2914                         CV * const gotocv = get_cvs("DB::goto", 0);
2915                         if (gotocv) {
2916                             PUSHMARK( PL_stack_sp );
2917                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2918                             PL_stack_sp--;
2919                         }
2920                     }
2921                 }
2922                 RETURNOP(CvSTART(cv));
2923             }
2924         }
2925         else {
2926             label = SvPV_nolen_const(sv);
2927             if (!(do_dump || *label))
2928                 DIE(aTHX_ must_have_label);
2929         }
2930     }
2931     else if (PL_op->op_flags & OPf_SPECIAL) {
2932         if (! do_dump)
2933             DIE(aTHX_ must_have_label);
2934     }
2935     else
2936         label = cPVOP->op_pv;
2937
2938     PERL_ASYNC_CHECK();
2939
2940     if (label && *label) {
2941         OP *gotoprobe = NULL;
2942         bool leaving_eval = FALSE;
2943         bool in_block = FALSE;
2944         PERL_CONTEXT *last_eval_cx = NULL;
2945
2946         /* find label */
2947
2948         PL_lastgotoprobe = NULL;
2949         *enterops = 0;
2950         for (ix = cxstack_ix; ix >= 0; ix--) {
2951             cx = &cxstack[ix];
2952             switch (CxTYPE(cx)) {
2953             case CXt_EVAL:
2954                 leaving_eval = TRUE;
2955                 if (!CxTRYBLOCK(cx)) {
2956                     gotoprobe = (last_eval_cx ?
2957                                 last_eval_cx->blk_eval.old_eval_root :
2958                                 PL_eval_root);
2959                     last_eval_cx = cx;
2960                     break;
2961                 }
2962                 /* else fall through */
2963             case CXt_LOOP_LAZYIV:
2964             case CXt_LOOP_LAZYSV:
2965             case CXt_LOOP_FOR:
2966             case CXt_LOOP_PLAIN:
2967             case CXt_GIVEN:
2968             case CXt_WHEN:
2969                 gotoprobe = cx->blk_oldcop->op_sibling;
2970                 break;
2971             case CXt_SUBST:
2972                 continue;
2973             case CXt_BLOCK:
2974                 if (ix) {
2975                     gotoprobe = cx->blk_oldcop->op_sibling;
2976                     in_block = TRUE;
2977                 } else
2978                     gotoprobe = PL_main_root;
2979                 break;
2980             case CXt_SUB:
2981                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2982                     gotoprobe = CvROOT(cx->blk_sub.cv);
2983                     break;
2984                 }
2985                 /* FALL THROUGH */
2986             case CXt_FORMAT:
2987             case CXt_NULL:
2988                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2989             default:
2990                 if (ix)
2991                     DIE(aTHX_ "panic: goto");
2992                 gotoprobe = PL_main_root;
2993                 break;
2994             }
2995             if (gotoprobe) {
2996                 retop = dofindlabel(gotoprobe, label,
2997                                     enterops, enterops + GOTO_DEPTH);
2998                 if (retop)
2999                     break;
3000                 if (gotoprobe->op_sibling &&
3001                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3002                         gotoprobe->op_sibling->op_sibling) {
3003                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3004                                         label, enterops, enterops + GOTO_DEPTH);
3005                     if (retop)
3006                         break;
3007                 }
3008             }
3009             PL_lastgotoprobe = gotoprobe;
3010         }
3011         if (!retop)
3012             DIE(aTHX_ "Can't find label %s", label);
3013
3014         /* if we're leaving an eval, check before we pop any frames
3015            that we're not going to punt, otherwise the error
3016            won't be caught */
3017
3018         if (leaving_eval && *enterops && enterops[1]) {
3019             I32 i;
3020             for (i = 1; enterops[i]; i++)
3021                 if (enterops[i]->op_type == OP_ENTERITER)
3022                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3023         }
3024
3025         if (*enterops && enterops[1]) {
3026             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3027             if (enterops[i])
3028                 deprecate("\"goto\" to jump into a construct");
3029         }
3030
3031         /* pop unwanted frames */
3032
3033         if (ix < cxstack_ix) {
3034             I32 oldsave;
3035
3036             if (ix < 0)
3037                 ix = 0;
3038             dounwind(ix);
3039             TOPBLOCK(cx);
3040             oldsave = PL_scopestack[PL_scopestack_ix];
3041             LEAVE_SCOPE(oldsave);
3042         }
3043
3044         /* push wanted frames */
3045
3046         if (*enterops && enterops[1]) {
3047             OP * const oldop = PL_op;
3048             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3049             for (; enterops[ix]; ix++) {
3050                 PL_op = enterops[ix];
3051                 /* Eventually we may want to stack the needed arguments
3052                  * for each op.  For now, we punt on the hard ones. */
3053                 if (PL_op->op_type == OP_ENTERITER)
3054                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3055                 PL_op->op_ppaddr(aTHX);
3056             }
3057             PL_op = oldop;
3058         }
3059     }
3060
3061     if (do_dump) {
3062 #ifdef VMS
3063         if (!retop) retop = PL_main_start;
3064 #endif
3065         PL_restartop = retop;
3066         PL_do_undump = TRUE;
3067
3068         my_unexec();
3069
3070         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3071         PL_do_undump = FALSE;
3072     }
3073
3074     RETURNOP(retop);
3075 }
3076
3077 PP(pp_exit)
3078 {
3079     dVAR;
3080     dSP;
3081     I32 anum;
3082
3083     if (MAXARG < 1)
3084         anum = 0;
3085     else {
3086         anum = SvIVx(POPs);
3087 #ifdef VMS
3088         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3089             anum = 0;
3090         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3091 #endif
3092     }
3093     PL_exit_flags |= PERL_EXIT_EXPECTED;
3094 #ifdef PERL_MAD
3095     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3096     if (anum || !(PL_minus_c && PL_madskills))
3097         my_exit(anum);
3098 #else
3099     my_exit(anum);
3100 #endif
3101     PUSHs(&PL_sv_undef);
3102     RETURN;
3103 }
3104
3105 /* Eval. */
3106
3107 STATIC void
3108 S_save_lines(pTHX_ AV *array, SV *sv)
3109 {
3110     const char *s = SvPVX_const(sv);
3111     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3112     I32 line = 1;
3113
3114     PERL_ARGS_ASSERT_SAVE_LINES;
3115
3116     while (s && s < send) {
3117         const char *t;
3118         SV * const tmpstr = newSV_type(SVt_PVMG);
3119
3120         t = (const char *)memchr(s, '\n', send - s);
3121         if (t)
3122             t++;
3123         else
3124             t = send;
3125
3126         sv_setpvn(tmpstr, s, t - s);
3127         av_store(array, line++, tmpstr);
3128         s = t;
3129     }
3130 }
3131
3132 /*
3133 =for apidoc docatch
3134
3135 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3136
3137 0 is used as continue inside eval,
3138
3139 3 is used for a die caught by an inner eval - continue inner loop
3140
3141 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3142 establish a local jmpenv to handle exception traps.
3143
3144 =cut
3145 */
3146 STATIC OP *
3147 S_docatch(pTHX_ OP *o)
3148 {
3149     dVAR;
3150     int ret;
3151     OP * const oldop = PL_op;
3152     dJMPENV;
3153
3154 #ifdef DEBUGGING
3155     assert(CATCH_GET == TRUE);
3156 #endif
3157     PL_op = o;
3158
3159     JMPENV_PUSH(ret);
3160     switch (ret) {
3161     case 0:
3162         assert(cxstack_ix >= 0);
3163         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3164         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3165  redo_body:
3166         CALLRUNOPS(aTHX);
3167         break;
3168     case 3:
3169         /* die caught by an inner eval - continue inner loop */
3170         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3171             PL_restartjmpenv = NULL;
3172             PL_op = PL_restartop;
3173             PL_restartop = 0;
3174             goto redo_body;
3175         }
3176         /* FALL THROUGH */
3177     default:
3178         JMPENV_POP;
3179         PL_op = oldop;
3180         JMPENV_JUMP(ret);
3181         /* NOTREACHED */
3182     }
3183     JMPENV_POP;
3184     PL_op = oldop;
3185     return NULL;
3186 }
3187
3188 /* James Bond: Do you expect me to talk?
3189    Auric Goldfinger: No, Mr. Bond. I expect you to die.
3190
3191    This code is an ugly hack, doesn't work with lexicals in subroutines that are
3192    called more than once, and is only used by regcomp.c, for (?{}) blocks.
3193
3194    Currently it is not used outside the core code. Best if it stays that way.
3195
3196    Hence it's now deprecated, and will be removed.
3197 */
3198 OP *
3199 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3200 /* sv Text to convert to OP tree. */
3201 /* startop op_free() this to undo. */
3202 /* code Short string id of the caller. */
3203 {
3204     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3205     return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3206 }
3207
3208 /* Don't use this. It will go away without warning once the regexp engine is
3209    refactored not to use it.  */
3210 OP *
3211 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3212                               PAD **padp)
3213 {
3214     dVAR; dSP;                          /* Make POPBLOCK work. */
3215     PERL_CONTEXT *cx;
3216     SV **newsp;
3217     I32 gimme = G_VOID;
3218     I32 optype;
3219     OP dummy;
3220     char tbuf[TYPE_DIGITS(long) + 12 + 10];
3221     char *tmpbuf = tbuf;
3222     char *safestr;
3223     int runtime;
3224     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3225     STRLEN len;
3226     bool need_catch;
3227
3228     PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3229
3230     ENTER_with_name("eval");
3231     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3232     SAVETMPS;
3233     /* switch to eval mode */
3234
3235     if (IN_PERL_COMPILETIME) {
3236         SAVECOPSTASH_FREE(&PL_compiling);
3237         CopSTASH_set(&PL_compiling, PL_curstash);
3238     }
3239     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3240         SV * const sv = sv_newmortal();
3241         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3242                        code, (unsigned long)++PL_evalseq,
3243                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3244         tmpbuf = SvPVX(sv);
3245         len = SvCUR(sv);
3246     }
3247     else
3248         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3249                           (unsigned long)++PL_evalseq);
3250     SAVECOPFILE_FREE(&PL_compiling);
3251     CopFILE_set(&PL_compiling, tmpbuf+2);
3252     SAVECOPLINE(&PL_compiling);
3253     CopLINE_set(&PL_compiling, 1);
3254     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3255        deleting the eval's FILEGV from the stash before gv_check() runs
3256        (i.e. before run-time proper). To work around the coredump that
3257        ensues, we always turn GvMULTI_on for any globals that were
3258        introduced within evals. See force_ident(). GSAR 96-10-12 */
3259     safestr = savepvn(tmpbuf, len);
3260     SAVEDELETE(PL_defstash, safestr, len);
3261     SAVEHINTS();
3262 #ifdef OP_IN_REGISTER
3263     PL_opsave = op;
3264 #else
3265     SAVEVPTR(PL_op);
3266 #endif
3267
3268     /* we get here either during compilation, or via pp_regcomp at runtime */
3269     runtime = IN_PERL_RUNTIME;
3270     if (runtime)
3271     {
3272         runcv = find_runcv(NULL);
3273
3274         /* At run time, we have to fetch the hints from PL_curcop. */
3275         PL_hints = PL_curcop->cop_hints;
3276         if (PL_hints & HINT_LOCALIZE_HH) {
3277             /* SAVEHINTS created a new HV in PL_hintgv, which we
3278                need to GC */
3279             SvREFCNT_dec(GvHV(PL_hintgv));
3280             GvHV(PL_hintgv) =
3281              refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3282             hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3283         }
3284         SAVECOMPILEWARNINGS();
3285         PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3286         cophh_free(CopHINTHASH_get(&PL_compiling));
3287         /* XXX Does this need to avoid copying a label? */
3288         PL_compiling.cop_hints_hash
3289          = cophh_copy(PL_curcop->cop_hints_hash);
3290     }
3291
3292     PL_op = &dummy;
3293     PL_op->op_type = OP_ENTEREVAL;
3294     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3295     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3296     PUSHEVAL(cx, 0);
3297     need_catch = CATCH_GET;
3298     CATCH_SET(TRUE);
3299
3300     if (runtime)
3301         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3302     else
3303         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3304     CATCH_SET(need_catch);
3305     POPBLOCK(cx,PL_curpm);
3306     POPEVAL(cx);
3307
3308     (*startop)->op_type = OP_NULL;
3309     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3310     /* XXX DAPM do this properly one year */
3311     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3312     LEAVE_with_name("eval");
3313     if (IN_PERL_COMPILETIME)
3314         CopHINTS_set(&PL_compiling, PL_hints);
3315 #ifdef OP_IN_REGISTER
3316     op = PL_opsave;
3317 #endif
3318     PERL_UNUSED_VAR(newsp);
3319     PERL_UNUSED_VAR(optype);
3320
3321     return PL_eval_start;
3322 }
3323
3324
3325 /*
3326 =for apidoc find_runcv
3327
3328 Locate the CV corresponding to the currently executing sub or eval.
3329 If db_seqp is non_null, skip CVs that are in the DB package and populate
3330 *db_seqp with the cop sequence number at the point that the DB:: code was
3331 entered. (allows debuggers to eval in the scope of the breakpoint rather
3332 than in the scope of the debugger itself).
3333
3334 =cut
3335 */
3336
3337 CV*
3338 Perl_find_runcv(pTHX_ U32 *db_seqp)
3339 {
3340     dVAR;
3341     PERL_SI      *si;
3342
3343     if (db_seqp)
3344         *db_seqp = PL_curcop->cop_seq;
3345     for (si = PL_curstackinfo; si; si = si->si_prev) {
3346         I32 ix;
3347         for (ix = si->si_cxix; ix >= 0; ix--) {
3348             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3349             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3350                 CV * const cv = cx->blk_sub.cv;
3351                 /* skip DB:: code */
3352                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3353                     *db_seqp = cx->blk_oldcop->cop_seq;
3354                     continue;
3355                 }
3356                 return cv;
3357             }
3358             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3359                 return PL_compcv;
3360         }
3361     }
3362     return PL_main_cv;
3363 }
3364
3365
3366 /* Run yyparse() in a setjmp wrapper. Returns:
3367  *   0: yyparse() successful
3368  *   1: yyparse() failed
3369  *   3: yyparse() died
3370  */
3371 STATIC int
3372 S_try_yyparse(pTHX_ int gramtype)
3373 {
3374     int ret;
3375     dJMPENV;
3376
3377     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3378     JMPENV_PUSH(ret);
3379     switch (ret) {
3380     case 0:
3381         ret = yyparse(gramtype) ? 1 : 0;
3382         break;
3383     case 3:
3384         break;
3385     default:
3386         JMPENV_POP;
3387         JMPENV_JUMP(ret);
3388         /* NOTREACHED */
3389     }
3390     JMPENV_POP;
3391     return ret;
3392 }
3393
3394
3395 /* Compile a require/do, an eval '', or a /(?{...})/.
3396  * In the last case, startop is non-null, and contains the address of
3397  * a pointer that should be set to the just-compiled code.
3398  * outside is the lexically enclosing CV (if any) that invoked us.
3399  * Returns a bool indicating whether the compile was successful; if so,
3400  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3401  * pushes undef (also croaks if startop != NULL).
3402  */
3403
3404 STATIC bool
3405 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3406 {
3407     dVAR; dSP;
3408     OP * const saveop = PL_op;
3409     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3410     int yystatus;
3411
3412     PL_in_eval = (in_require
3413                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3414                   : EVAL_INEVAL);
3415
3416     PUSHMARK(SP);
3417
3418     SAVESPTR(PL_compcv);
3419     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3420     CvEVAL_on(PL_compcv);
3421     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3422     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3423
3424     CvOUTSIDE_SEQ(PL_compcv) = seq;
3425     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3426
3427     /* set up a scratch pad */
3428
3429     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3430     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3431
3432
3433     if (!PL_madskills)
3434         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3435
3436     /* make sure we compile in the right package */
3437
3438     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3439         SAVESPTR(PL_curstash);
3440         PL_curstash = CopSTASH(PL_curcop);
3441     }
3442     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3443     SAVESPTR(PL_beginav);
3444     PL_beginav = newAV();
3445     SAVEFREESV(PL_beginav);
3446     SAVESPTR(PL_unitcheckav);
3447     PL_unitcheckav = newAV();
3448     SAVEFREESV(PL_unitcheckav);
3449
3450 #ifdef PERL_MAD
3451     SAVEBOOL(PL_madskills);
3452     PL_madskills = 0;
3453 #endif
3454
3455     /* try to compile it */
3456
3457     PL_eval_root = NULL;
3458     PL_curcop = &PL_compiling;
3459     CopARYBASE_set(PL_curcop, 0);
3460     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3461         PL_in_eval |= EVAL_KEEPERR;
3462     else
3463         CLEAR_ERRSV();
3464
3465     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3466
3467     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3468      * so honour CATCH_GET and trap it here if necessary */
3469
3470     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3471
3472     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3473         SV **newsp;                     /* Used by POPBLOCK. */
3474         PERL_CONTEXT *cx = NULL;
3475         I32 optype;                     /* Used by POPEVAL. */
3476         SV *namesv = NULL;
3477         const char *msg;
3478
3479         PERL_UNUSED_VAR(newsp);
3480         PERL_UNUSED_VAR(optype);
3481
3482         /* note that if yystatus == 3, then the EVAL CX block has already
3483          * been popped, and various vars restored */
3484         PL_op = saveop;
3485         if (yystatus != 3) {
3486             if (PL_eval_root) {
3487                 op_free(PL_eval_root);
3488                 PL_eval_root = NULL;
3489             }
3490             SP = PL_stack_base + POPMARK;       /* pop original mark */
3491             if (!startop) {
3492                 POPBLOCK(cx,PL_curpm);
3493                 POPEVAL(cx);
3494                 namesv = cx->blk_eval.old_namesv;
3495             }
3496         }
3497         if (yystatus != 3)
3498             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3499
3500         msg = SvPVx_nolen_const(ERRSV);
3501         if (in_require) {
3502             if (!cx) {
3503                 /* If cx is still NULL, it means that we didn't go in the
3504                  * POPEVAL branch. */
3505                 cx = &cxstack[cxstack_ix];
3506                 assert(CxTYPE(cx) == CXt_EVAL);
3507                 namesv = cx->blk_eval.old_namesv;
3508             }
3509             (void)hv_store(GvHVn(PL_incgv),
3510                            SvPVX_const(namesv), SvCUR(namesv),
3511                            &PL_sv_undef, 0);
3512             Perl_croak(aTHX_ "%sCompilation failed in require",
3513                        *msg ? msg : "Unknown error\n");
3514         }
3515         else if (startop) {
3516             if (yystatus != 3) {
3517                 POPBLOCK(cx,PL_curpm);
3518                 POPEVAL(cx);
3519             }
3520             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3521                        (*msg ? msg : "Unknown error\n"));
3522         }
3523         else {
3524             if (!*msg) {
3525                 sv_setpvs(ERRSV, "Compilation error");
3526             }
3527         }
3528         PUSHs(&PL_sv_undef);
3529         PUTBACK;
3530         return FALSE;
3531     }
3532     CopLINE_set(&PL_compiling, 0);
3533     if (startop) {
3534         *startop = PL_eval_root;
3535     } else
3536         SAVEFREEOP(PL_eval_root);
3537
3538     /* Set the context for this new optree.
3539      * Propagate the context from the eval(). */
3540     if ((gimme & G_WANT) == G_VOID)
3541         scalarvoid(PL_eval_root);
3542     else if ((gimme & G_WANT) == G_ARRAY)
3543         list(PL_eval_root);
3544     else
3545         scalar(PL_eval_root);
3546
3547     DEBUG_x(dump_eval());
3548
3549     /* Register with debugger: */
3550     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3551         CV * const cv = get_cvs("DB::postponed", 0);
3552         if (cv) {
3553             dSP;
3554             PUSHMARK(SP);
3555             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3556             PUTBACK;
3557             call_sv(MUTABLE_SV(cv), G_DISCARD);
3558         }
3559     }
3560
3561     if (PL_unitcheckav) {
3562         OP *es = PL_eval_start;
3563         call_list(PL_scopestack_ix, PL_unitcheckav);
3564         PL_eval_start = es;
3565     }
3566
3567     /* compiled okay, so do it */
3568
3569     CvDEPTH(PL_compcv) = 1;
3570     SP = PL_stack_base + POPMARK;               /* pop original mark */
3571     PL_op = saveop;                     /* The caller may need it. */
3572     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3573
3574     PUTBACK;
3575     return TRUE;
3576 }
3577
3578 STATIC PerlIO *
3579 S_check_type_and_open(pTHX_ SV *name)
3580 {
3581     Stat_t st;
3582     const char *p = SvPV_nolen_const(name);
3583     const int st_rc = PerlLIO_stat(p, &st);
3584
3585     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3586
3587     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3588         return NULL;
3589     }
3590
3591 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3592     return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3593 #else
3594     return PerlIO_open(p, PERL_SCRIPT_MODE);
3595 #endif
3596 }
3597
3598 #ifndef PERL_DISABLE_PMC
3599 STATIC PerlIO *
3600 S_doopen_pm(pTHX_ SV *name)
3601 {
3602     STRLEN namelen;
3603     const char *p = SvPV_const(name, namelen);
3604
3605     PERL_ARGS_ASSERT_DOOPEN_PM;
3606
3607     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3608         SV *const pmcsv = sv_newmortal();
3609         Stat_t pmcstat;
3610
3611         SvSetSV_nosteal(pmcsv,name);
3612         sv_catpvn(pmcsv, "c", 1);
3613
3614         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3615             return check_type_and_open(pmcsv);
3616     }
3617     return check_type_and_open(name);
3618 }
3619 #else
3620 #  define doopen_pm(name) check_type_and_open(name)
3621 #endif /* !PERL_DISABLE_PMC */
3622
3623 PP(pp_require)
3624 {
3625     dVAR; dSP;
3626     register PERL_CONTEXT *cx;
3627     SV *sv;
3628     const char *name;
3629     STRLEN len;
3630     char * unixname;
3631     STRLEN unixlen;
3632 #ifdef VMS
3633     int vms_unixname = 0;
3634 #endif
3635     const char *tryname = NULL;
3636     SV *namesv = NULL;
3637     const I32 gimme = GIMME_V;
3638     int filter_has_file = 0;
3639     PerlIO *tryrsfp = NULL;
3640     SV *filter_cache = NULL;
3641     SV *filter_state = NULL;
3642     SV *filter_sub = NULL;
3643     SV *hook_sv = NULL;
3644     SV *encoding;
3645     OP *op;
3646
3647     sv = POPs;
3648     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3649         sv = sv_2mortal(new_version(sv));
3650         if (!sv_derived_from(PL_patchlevel, "version"))
3651             upg_version(PL_patchlevel, TRUE);
3652         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3653             if ( vcmp(sv,PL_patchlevel) <= 0 )
3654                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3655                     SVfARG(sv_2mortal(vnormal(sv))),
3656                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3657                 );
3658         }
3659         else {
3660             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3661                 I32 first = 0;
3662                 AV *lav;
3663                 SV * const req = SvRV(sv);
3664                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3665
3666                 /* get the left hand term */
3667                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3668
3669                 first  = SvIV(*av_fetch(lav,0,0));
3670                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3671                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3672                     || av_len(lav) > 1               /* FP with > 3 digits */
3673                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3674                    ) {
3675                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3676                         "%"SVf", stopped",
3677                         SVfARG(sv_2mortal(vnormal(req))),
3678                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3679                     );
3680                 }
3681                 else { /* probably 'use 5.10' or 'use 5.8' */
3682                     SV *hintsv;
3683                     I32 second = 0;
3684
3685                     if (av_len(lav)>=1)
3686                         second = SvIV(*av_fetch(lav,1,0));
3687
3688                     second /= second >= 600  ? 100 : 10;
3689                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3690                                            (int)first, (int)second);
3691                     upg_version(hintsv, TRUE);
3692
3693                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3694                         "--this is only %"SVf", stopped",
3695                         SVfARG(sv_2mortal(vnormal(req))),
3696                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3697                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3698                     );
3699                 }
3700             }
3701         }
3702
3703         RETPUSHYES;
3704     }
3705     name = SvPV_const(sv, len);
3706     if (!(name && len > 0 && *name))
3707         DIE(aTHX_ "Null filename used");
3708     TAINT_PROPER("require");
3709
3710
3711 #ifdef VMS
3712     /* The key in the %ENV hash is in the syntax of file passed as the argument
3713      * usually this is in UNIX format, but sometimes in VMS format, which
3714      * can result in a module being pulled in more than once.
3715      * To prevent this, the key must be stored in UNIX format if the VMS
3716      * name can be translated to UNIX.
3717      */
3718     if ((unixname = tounixspec(name, NULL)) != NULL) {
3719         unixlen = strlen(unixname);
3720         vms_unixname = 1;
3721     }
3722     else
3723 #endif
3724     {
3725         /* if not VMS or VMS name can not be translated to UNIX, pass it
3726          * through.
3727          */
3728         unixname = (char *) name;
3729         unixlen = len;
3730     }
3731     if (PL_op->op_type == OP_REQUIRE) {
3732         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3733                                           unixname, unixlen, 0);
3734         if ( svp ) {
3735             if (*svp != &PL_sv_undef)
3736                 RETPUSHYES;
3737             else
3738                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3739                             "Compilation failed in require", unixname);
3740         }
3741     }
3742
3743     /* prepare to compile file */
3744
3745     if (path_is_absolute(name)) {
3746         /* At this point, name is SvPVX(sv)  */
3747         tryname = name;
3748         tryrsfp = doopen_pm(sv);
3749     }
3750     if (!tryrsfp) {
3751         AV * const ar = GvAVn(PL_incgv);
3752         I32 i;
3753 #ifdef VMS
3754         if (vms_unixname)
3755 #endif
3756         {
3757             namesv = newSV_type(SVt_PV);
3758             for (i = 0; i <= AvFILL(ar); i++) {
3759                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3760
3761                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3762                     mg_get(dirsv);
3763                 if (SvROK(dirsv)) {
3764                     int count;
3765                     SV **svp;
3766                     SV *loader = dirsv;
3767
3768                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3769                         && !sv_isobject(loader))
3770                     {
3771                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3772                     }
3773
3774                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3775                                    PTR2UV(SvRV(dirsv)), name);
3776                     tryname = SvPVX_const(namesv);
3777                     tryrsfp = NULL;
3778
3779                     ENTER_with_name("call_INC");
3780                     SAVETMPS;
3781                     EXTEND(SP, 2);
3782
3783                     PUSHMARK(SP);
3784                     PUSHs(dirsv);
3785                     PUSHs(sv);
3786                     PUTBACK;
3787                     if (sv_isobject(loader))
3788                         count = call_method("INC", G_ARRAY);
3789                     else
3790                         count = call_sv(loader, G_ARRAY);
3791                     SPAGAIN;
3792
3793                     if (count > 0) {
3794                         int i = 0;
3795                         SV *arg;
3796
3797                         SP -= count - 1;
3798                         arg = SP[i++];
3799
3800                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3801                             && !isGV_with_GP(SvRV(arg))) {
3802                             filter_cache = SvRV(arg);
3803                             SvREFCNT_inc_simple_void_NN(filter_cache);
3804
3805                             if (i < count) {
3806                                 arg = SP[i++];
3807                             }
3808                         }
3809
3810                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3811                             arg = SvRV(arg);
3812                         }
3813
3814                         if (isGV_with_GP(arg)) {
3815                             IO * const io = GvIO((const GV *)arg);
3816
3817                             ++filter_has_file;
3818
3819                             if (io) {
3820                                 tryrsfp = IoIFP(io);
3821                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3822                                     PerlIO_close(IoOFP(io));
3823                                 }
3824                                 IoIFP(io) = NULL;
3825                                 IoOFP(io) = NULL;
3826                             }
3827
3828                             if (i < count) {
3829                                 arg = SP[i++];
3830                             }
3831                         }
3832
3833                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3834                             filter_sub = arg;
3835                             SvREFCNT_inc_simple_void_NN(filter_sub);
3836
3837                             if (i < count) {
3838                                 filter_state = SP[i];
3839                                 SvREFCNT_inc_simple_void(filter_state);
3840                             }
3841                         }
3842
3843                         if (!tryrsfp && (filter_cache || filter_sub)) {
3844                             tryrsfp = PerlIO_open(BIT_BUCKET,
3845                                                   PERL_SCRIPT_MODE);
3846                         }
3847                         SP--;
3848                     }
3849
3850                     PUTBACK;
3851                     FREETMPS;
3852                     LEAVE_with_name("call_INC");
3853
3854                     /* Adjust file name if the hook has set an %INC entry.
3855                        This needs to happen after the FREETMPS above.  */
3856                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3857                     if (svp)
3858                         tryname = SvPV_nolen_const(*svp);
3859
3860                     if (tryrsfp) {
3861                         hook_sv = dirsv;
3862                         break;
3863                     }
3864
3865                     filter_has_file = 0;
3866                     if (filter_cache) {
3867                         SvREFCNT_dec(filter_cache);
3868                         filter_cache = NULL;
3869                     }
3870                     if (filter_state) {
3871                         SvREFCNT_dec(filter_state);
3872                         filter_state = NULL;
3873                     }
3874                     if (filter_sub) {
3875                         SvREFCNT_dec(filter_sub);
3876                         filter_sub = NULL;
3877                     }
3878                 }
3879                 else {
3880                   if (!path_is_absolute(name)
3881                   ) {
3882                     const char *dir;
3883                     STRLEN dirlen;
3884
3885                     if (SvOK(dirsv)) {
3886                         dir = SvPV_const(dirsv, dirlen);
3887                     } else {
3888                         dir = "";
3889                         dirlen = 0;
3890                     }
3891
3892 #ifdef VMS
3893                     char *unixdir;
3894                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3895                         continue;
3896                     sv_setpv(namesv, unixdir);
3897                     sv_catpv(namesv, unixname);
3898 #else
3899 #  ifdef __SYMBIAN32__
3900                     if (PL_origfilename[0] &&
3901                         PL_origfilename[1] == ':' &&
3902                         !(dir[0] && dir[1] == ':'))
3903                         Perl_sv_setpvf(aTHX_ namesv,
3904                                        "%c:%s\\%s",
3905                                        PL_origfilename[0],
3906                                        dir, name);
3907                     else
3908                         Perl_sv_setpvf(aTHX_ namesv,
3909                                        "%s\\%s",
3910                                        dir, name);
3911 #  else
3912                     /* The equivalent of
3913                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3914                        but without the need to parse the format string, or
3915                        call strlen on either pointer, and with the correct
3916                        allocation up front.  */
3917                     {
3918                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3919
3920                         memcpy(tmp, dir, dirlen);
3921                         tmp +=dirlen;
3922                         *tmp++ = '/';
3923                         /* name came from an SV, so it will have a '\0' at the
3924                            end that we can copy as part of this memcpy().  */
3925                         memcpy(tmp, name, len + 1);
3926
3927                         SvCUR_set(namesv, dirlen + len + 1);
3928                         SvPOK_on(namesv);
3929                     }
3930 #  endif
3931 #endif
3932                     TAINT_PROPER("require");
3933                     tryname = SvPVX_const(namesv);
3934                     tryrsfp = doopen_pm(namesv);
3935                     if (tryrsfp) {
3936                         if (tryname[0] == '.' && tryname[1] == '/') {
3937                             ++tryname;
3938                             while (*++tryname == '/');
3939                         }
3940                         break;
3941                     }
3942                     else if (errno == EMFILE)
3943                         /* no point in trying other paths if out of handles */
3944                         break;
3945                   }
3946                 }
3947             }
3948         }
3949     }
3950     sv_2mortal(namesv);
3951     if (!tryrsfp) {
3952         if (PL_op->op_type == OP_REQUIRE) {
3953             if(errno == EMFILE) {
3954                 /* diag_listed_as: Can't locate %s */
3955                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3956             } else {
3957                 if (namesv) {                   /* did we lookup @INC? */
3958                     AV * const ar = GvAVn(PL_incgv);
3959                     I32 i;
3960                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3961                     for (i = 0; i <= AvFILL(ar); i++) {
3962                         sv_catpvs(inc, " ");
3963                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3964                     }
3965
3966                     /* diag_listed_as: Can't locate %s */
3967                     DIE(aTHX_
3968                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3969                         name,
3970                         (memEQ(name + len - 2, ".h", 3)
3971                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3972                         (memEQ(name + len - 3, ".ph", 4)
3973                          ? " (did you run h2ph?)" : ""),
3974                         inc
3975                         );
3976                 }
3977             }
3978             DIE(aTHX_ "Can't locate %s", name);
3979         }
3980
3981         RETPUSHUNDEF;
3982     }
3983     else
3984         SETERRNO(0, SS_NORMAL);
3985
3986     /* Assume success here to prevent recursive requirement. */
3987     /* name is never assigned to again, so len is still strlen(name)  */
3988     /* Check whether a hook in @INC has already filled %INC */
3989     if (!hook_sv) {
3990         (void)hv_store(GvHVn(PL_incgv),
3991                        unixname, unixlen, newSVpv(tryname,0),0);
3992     } else {
3993         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3994         if (!svp)
3995             (void)hv_store(GvHVn(PL_incgv),
3996                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3997     }
3998
3999     ENTER_with_name("eval");
4000     SAVETMPS;
4001     SAVECOPFILE_FREE(&PL_compiling);
4002     CopFILE_set(&PL_compiling, tryname);
4003     lex_start(NULL, tryrsfp, 0);
4004
4005     SAVEHINTS();
4006     PL_hints = 0;
4007     hv_clear(GvHV(PL_hintgv));
4008
4009     SAVECOMPILEWARNINGS();
4010     if (PL_dowarn & G_WARN_ALL_ON)
4011         PL_compiling.cop_warnings = pWARN_ALL ;
4012     else if (PL_dowarn & G_WARN_ALL_OFF)
4013         PL_compiling.cop_warnings = pWARN_NONE ;
4014     else
4015         PL_compiling.cop_warnings = pWARN_STD ;
4016
4017     if (filter_sub || filter_cache) {
4018         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4019            than hanging another SV from it. In turn, filter_add() optionally
4020            takes the SV to use as the filter (or creates a new SV if passed
4021            NULL), so simply pass in whatever value filter_cache has.  */
4022         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4023         IoLINES(datasv) = filter_has_file;
4024         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4025         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4026     }
4027
4028     /* switch to eval mode */
4029     PUSHBLOCK(cx, CXt_EVAL, SP);
4030     PUSHEVAL(cx, name);
4031     cx->blk_eval.retop = PL_op->op_next;
4032
4033     SAVECOPLINE(&PL_compiling);
4034     CopLINE_set(&PL_compiling, 0);
4035
4036     PUTBACK;
4037
4038     /* Store and reset encoding. */
4039     encoding = PL_encoding;
4040     PL_encoding = NULL;
4041
4042     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
4043         op = DOCATCH(PL_eval_start);
4044     else
4045         op = PL_op->op_next;
4046
4047     /* Restore encoding. */
4048     PL_encoding = encoding;
4049
4050     return op;
4051 }
4052
4053 /* This is a op added to hold the hints hash for
4054    pp_entereval. The hash can be modified by the code
4055    being eval'ed, so we return a copy instead. */
4056
4057 PP(pp_hintseval)
4058 {
4059     dVAR;
4060     dSP;
4061     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4062     RETURN;
4063 }
4064
4065
4066 PP(pp_entereval)
4067 {
4068     dVAR; dSP;
4069     register PERL_CONTEXT *cx;
4070     SV *sv;
4071     const I32 gimme = GIMME_V;
4072     const U32 was = PL_breakable_sub_gen;
4073     char tbuf[TYPE_DIGITS(long) + 12];
4074     bool saved_delete = FALSE;
4075     char *tmpbuf = tbuf;
4076     STRLEN len;
4077     CV* runcv;
4078     U32 seq;
4079     HV *saved_hh = NULL;
4080
4081     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4082         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4083     }
4084     sv = POPs;
4085     if (!SvPOK(sv)) {
4086         /* make sure we've got a plain PV (no overload etc) before testing
4087          * for taint. Making a copy here is probably overkill, but better
4088          * safe than sorry */
4089         STRLEN len;
4090         const char * const p = SvPV_const(sv, len);
4091
4092         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4093     }
4094
4095     TAINT_IF(SvTAINTED(sv));
4096     TAINT_PROPER("eval");
4097
4098     ENTER_with_name("eval");
4099     lex_start(sv, NULL, LEX_START_SAME_FILTER);
4100     SAVETMPS;
4101
4102     /* switch to eval mode */
4103
4104     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4105         SV * const temp_sv = sv_newmortal();
4106         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4107                        (unsigned long)++PL_evalseq,
4108                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4109         tmpbuf = SvPVX(temp_sv);
4110         len = SvCUR(temp_sv);
4111     }
4112     else
4113         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4114     SAVECOPFILE_FREE(&PL_compiling);
4115     CopFILE_set(&PL_compiling, tmpbuf+2);
4116     SAVECOPLINE(&PL_compiling);
4117     CopLINE_set(&PL_compiling, 1);
4118     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4119        deleting the eval's FILEGV from the stash before gv_check() runs
4120        (i.e. before run-time proper). To work around the coredump that
4121        ensues, we always turn GvMULTI_on for any globals that were
4122        introduced within evals. See force_ident(). GSAR 96-10-12 */
4123     SAVEHINTS();
4124     PL_hints = PL_op->op_targ;
4125     if (saved_hh) {
4126         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4127         SvREFCNT_dec(GvHV(PL_hintgv));
4128         GvHV(PL_hintgv) = saved_hh;
4129     }
4130     SAVECOMPILEWARNINGS();
4131     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4132     cophh_free(CopHINTHASH_get(&PL_compiling));
4133     if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
4134         /* The label, if present, is the first entry on the chain. So rather
4135            than writing a blank label in front of it (which involves an
4136            allocation), just use the next entry in the chain.  */
4137         PL_compiling.cop_hints_hash
4138             = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4139         /* Check the assumption that this removed the label.  */
4140         assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4141     }
4142     else
4143         PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4144     /* special case: an eval '' executed within the DB package gets lexically
4145      * placed in the first non-DB CV rather than the current CV - this
4146      * allows the debugger to execute code, find lexicals etc, in the
4147      * scope of the code being debugged. Passing &seq gets find_runcv
4148      * to do the dirty work for us */
4149     runcv = find_runcv(&seq);
4150
4151     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4152     PUSHEVAL(cx, 0);
4153     cx->blk_eval.retop = PL_op->op_next;
4154
4155     /* prepare to compile string */
4156
4157     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4158         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4159     else {
4160         char *const safestr = savepvn(tmpbuf, len);
4161         SAVEDELETE(PL_defstash, safestr, len);
4162         saved_delete = TRUE;
4163     }
4164
4165     PUTBACK;
4166
4167     if (doeval(gimme, NULL, runcv, seq)) {
4168         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4169             ? (PERLDB_LINE || PERLDB_SAVESRC)
4170             :  PERLDB_SAVESRC_NOSUBS) {
4171             /* Retain the filegv we created.  */
4172         } else if (!saved_delete) {
4173             char *const safestr = savepvn(tmpbuf, len);
4174             SAVEDELETE(PL_defstash, safestr, len);
4175         }
4176         return DOCATCH(PL_eval_start);
4177     } else {
4178         /* We have already left the scope set up earlier thanks to the LEAVE
4179            in doeval().  */
4180         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4181             ? (PERLDB_LINE || PERLDB_SAVESRC)
4182             :  PERLDB_SAVESRC_INVALID) {
4183             /* Retain the filegv we created.  */
4184         } else if (!saved_delete) {
4185             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4186         }
4187         return PL_op->op_next;
4188     }
4189 }
4190
4191 PP(pp_leaveeval)
4192 {
4193     dVAR; dSP;
4194     register SV **mark;
4195     SV **newsp;
4196     PMOP *newpm;
4197     I32 gimme;
4198     register PERL_CONTEXT *cx;
4199     OP *retop;
4200     const U8 save_flags = PL_op -> op_flags;
4201     I32 optype;
4202     SV *namesv;
4203
4204     PERL_ASYNC_CHECK();
4205     POPBLOCK(cx,newpm);
4206     POPEVAL(cx);
4207     namesv = cx->blk_eval.old_namesv;
4208     retop = cx->blk_eval.retop;
4209
4210     TAINT_NOT;
4211     if (gimme == G_VOID)
4212         MARK = newsp;
4213     else if (gimme == G_SCALAR) {
4214         MARK = newsp + 1;
4215         if (MARK <= SP) {
4216             if (SvFLAGS(TOPs) & SVs_TEMP)
4217                 *MARK = TOPs;
4218             else
4219                 *MARK = sv_mortalcopy(TOPs);
4220         }
4221         else {
4222             MEXTEND(mark,0);
4223             *MARK = &PL_sv_undef;
4224         }
4225         SP = MARK;
4226     }
4227     else {
4228         /* in case LEAVE wipes old return values */
4229         for (mark = newsp + 1; mark <= SP; mark++) {
4230             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4231                 *mark = sv_mortalcopy(*mark);
4232                 TAINT_NOT;      /* Each item is independent */
4233             }
4234         }
4235     }
4236     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4237
4238 #ifdef DEBUGGING
4239     assert(CvDEPTH(PL_compcv) == 1);
4240 #endif
4241     CvDEPTH(PL_compcv) = 0;
4242
4243     if (optype == OP_REQUIRE &&
4244         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4245     {
4246         /* Unassume the success we assumed earlier. */
4247         (void)hv_delete(GvHVn(PL_incgv),
4248                         SvPVX_const(namesv), SvCUR(namesv),
4249                         G_DISCARD);
4250         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4251                                SVfARG(namesv));
4252         /* die_unwind() did LEAVE, or we won't be here */
4253     }
4254     else {
4255         LEAVE_with_name("eval");
4256         if (!(save_flags & OPf_SPECIAL)) {
4257             CLEAR_ERRSV();
4258         }
4259     }
4260
4261     RETURNOP(retop);
4262 }
4263
4264 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4265    close to the related Perl_create_eval_scope.  */
4266 void
4267 Perl_delete_eval_scope(pTHX)
4268 {
4269     SV **newsp;
4270     PMOP *newpm;
4271     I32 gimme;
4272     register PERL_CONTEXT *cx;
4273     I32 optype;
4274
4275     POPBLOCK(cx,newpm);
4276     POPEVAL(cx);
4277     PL_curpm = newpm;
4278     LEAVE_with_name("eval_scope");
4279     PERL_UNUSED_VAR(newsp);
4280     PERL_UNUSED_VAR(gimme);
4281     PERL_UNUSED_VAR(optype);
4282 }
4283
4284 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4285    also needed by Perl_fold_constants.  */
4286 PERL_CONTEXT *
4287 Perl_create_eval_scope(pTHX_ U32 flags)
4288 {
4289     PERL_CONTEXT *cx;
4290     const I32 gimme = GIMME_V;
4291
4292     ENTER_with_name("eval_scope");
4293     SAVETMPS;
4294
4295     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4296     PUSHEVAL(cx, 0);
4297
4298     PL_in_eval = EVAL_INEVAL;
4299     if (flags & G_KEEPERR)
4300         PL_in_eval |= EVAL_KEEPERR;
4301     else
4302         CLEAR_ERRSV();
4303     if (flags & G_FAKINGEVAL) {
4304         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4305     }
4306     return cx;
4307 }
4308
4309 PP(pp_entertry)
4310 {
4311     dVAR;
4312     PERL_CONTEXT * const cx = create_eval_scope(0);
4313     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4314     return DOCATCH(PL_op->op_next);
4315 }
4316
4317 PP(pp_leavetry)
4318 {
4319     dVAR; dSP;
4320     SV **newsp;
4321     PMOP *newpm;
4322     I32 gimme;
4323     register PERL_CONTEXT *cx;
4324     I32 optype;
4325
4326     PERL_ASYNC_CHECK();
4327     POPBLOCK(cx,newpm);
4328     POPEVAL(cx);
4329     PERL_UNUSED_VAR(optype);
4330
4331     TAINT_NOT;
4332     if (gimme == G_VOID)
4333         SP = newsp;
4334     else if (gimme == G_SCALAR) {
4335         register SV **mark;
4336         MARK = newsp + 1;
4337         if (MARK <= SP) {
4338             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4339                 *MARK = TOPs;
4340             else
4341                 *MARK = sv_mortalcopy(TOPs);
4342         }
4343         else {
4344             MEXTEND(mark,0);
4345             *MARK = &PL_sv_undef;
4346         }
4347         SP = MARK;
4348     }
4349     else {
4350         /* in case LEAVE wipes old return values */
4351         register SV **mark;
4352         for (mark = newsp + 1; mark <= SP; mark++) {
4353             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4354                 *mark = sv_mortalcopy(*mark);
4355                 TAINT_NOT;      /* Each item is independent */
4356             }
4357         }
4358     }
4359     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4360
4361     LEAVE_with_name("eval_scope");
4362     CLEAR_ERRSV();
4363     RETURN;
4364 }
4365
4366 PP(pp_entergiven)
4367 {
4368     dVAR; dSP;
4369     register PERL_CONTEXT *cx;
4370     const I32 gimme = GIMME_V;
4371
4372     ENTER_with_name("given");
4373     SAVETMPS;
4374
4375     sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4376
4377     PUSHBLOCK(cx, CXt_GIVEN, SP);
4378     PUSHGIVEN(cx);
4379
4380     RETURN;
4381 }
4382
4383 PP(pp_leavegiven)
4384 {
4385     dVAR; dSP;
4386     register PERL_CONTEXT *cx;
4387     I32 gimme;
4388     SV **newsp;
4389     PMOP *newpm;
4390     PERL_UNUSED_CONTEXT;
4391
4392     POPBLOCK(cx,newpm);
4393     assert(CxTYPE(cx) == CXt_GIVEN);
4394
4395     TAINT_NOT;
4396     if (gimme == G_VOID)
4397         SP = newsp;
4398     else if (gimme == G_SCALAR) {
4399         register SV **mark;
4400         MARK = newsp + 1;
4401         if (MARK <= SP) {
4402             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4403                 *MARK = TOPs;
4404             else
4405                 *MARK = sv_mortalcopy(TOPs);
4406         }
4407         else {
4408             MEXTEND(mark,0);
4409             *MARK = &PL_sv_undef;
4410         }
4411         SP = MARK;
4412     }
4413     else {
4414         /* in case LEAVE wipes old return values */
4415         register SV **mark;
4416         for (mark = newsp + 1; mark <= SP; mark++) {
4417             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4418                 *mark = sv_mortalcopy(*mark);
4419                 TAINT_NOT;      /* Each item is independent */
4420             }
4421         }
4422     }
4423     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4424
4425     LEAVE_with_name("given");
4426     RETURN;
4427 }
4428
4429 /* Helper routines used by pp_smartmatch */
4430 STATIC PMOP *
4431 S_make_matcher(pTHX_ REGEXP *re)
4432 {
4433     dVAR;
4434     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4435
4436     PERL_ARGS_ASSERT_MAKE_MATCHER;
4437
4438     PM_SETRE(matcher, ReREFCNT_inc(re));
4439
4440     SAVEFREEOP((OP *) matcher);
4441     ENTER_with_name("matcher"); SAVETMPS;
4442     SAVEOP();
4443     return matcher;
4444 }
4445
4446 STATIC bool
4447 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4448 {
4449     dVAR;
4450     dSP;
4451
4452     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4453
4454     PL_op = (OP *) matcher;
4455     XPUSHs(sv);
4456     PUTBACK;
4457     (void) Perl_pp_match(aTHX);
4458     SPAGAIN;
4459     return (SvTRUEx(POPs));
4460 }
4461
4462 STATIC void
4463 S_destroy_matcher(pTHX_ PMOP *matcher)
4464 {
4465     dVAR;
4466
4467     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4468     PERL_UNUSED_ARG(matcher);
4469
4470     FREETMPS;
4471     LEAVE_with_name("matcher");
4472 }
4473
4474 /* Do a smart match */
4475 PP(pp_smartmatch)
4476 {
4477     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4478     return do_smartmatch(NULL, NULL);
4479 }
4480
4481 /* This version of do_smartmatch() implements the
4482  * table of smart matches that is found in perlsyn.
4483  */
4484 STATIC OP *
4485 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4486 {
4487     dVAR;
4488     dSP;
4489
4490     bool object_on_left = FALSE;
4491     SV *e = TOPs;       /* e is for 'expression' */
4492     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4493
4494     /* Take care only to invoke mg_get() once for each argument.
4495      * Currently we do this by copying the SV if it's magical. */
4496     if (d) {
4497         if (SvGMAGICAL(d))
4498             d = sv_mortalcopy(d);
4499     }
4500     else
4501         d = &PL_sv_undef;
4502
4503     assert(e);
4504     if (SvGMAGICAL(e))
4505         e = sv_mortalcopy(e);
4506
4507     /* First of all, handle overload magic of the rightmost argument */
4508     if (SvAMAGIC(e)) {
4509         SV * tmpsv;
4510         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4511         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4512
4513         tmpsv = amagic_call(d, e, smart_amg, 0);
4514         if (tmpsv) {
4515             SPAGAIN;
4516             (void)POPs;
4517             SETs(tmpsv);
4518             RETURN;
4519         }
4520         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4521     }
4522
4523     SP -= 2;    /* Pop the values */
4524
4525
4526     /* ~~ undef */
4527     if (!SvOK(e)) {
4528         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4529         if (SvOK(d))
4530             RETPUSHNO;
4531         else
4532             RETPUSHYES;
4533     }
4534
4535     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4536         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4537         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4538     }
4539     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4540         object_on_left = TRUE;
4541
4542     /* ~~ sub */
4543     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4544         I32 c;
4545         if (object_on_left) {
4546             goto sm_any_sub; /* Treat objects like scalars */
4547         }
4548         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4549             /* Test sub truth for each key */
4550             HE *he;
4551             bool andedresults = TRUE;
4552             HV *hv = (HV*) SvRV(d);
4553             I32 numkeys = hv_iterinit(hv);
4554             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4555             if (numkeys == 0)
4556                 RETPUSHYES;
4557             while ( (he = hv_iternext(hv)) ) {
4558                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4559                 ENTER_with_name("smartmatch_hash_key_test");
4560                 SAVETMPS;
4561                 PUSHMARK(SP);
4562                 PUSHs(hv_iterkeysv(he));
4563                 PUTBACK;
4564                 c = call_sv(e, G_SCALAR);
4565                 SPAGAIN;
4566                 if (c == 0)
4567                     andedresults = FALSE;
4568                 else
4569                     andedresults = SvTRUEx(POPs) && andedresults;
4570                 FREETMPS;
4571                 LEAVE_with_name("smartmatch_hash_key_test");
4572             }
4573             if (andedresults)
4574                 RETPUSHYES;
4575             else
4576                 RETPUSHNO;
4577         }
4578         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4579             /* Test sub truth for each element */
4580             I32 i;
4581             bool andedresults = TRUE;
4582             AV *av = (AV*) SvRV(d);
4583             const I32 len = av_len(av);
4584             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4585             if (len == -1)
4586                 RETPUSHYES;
4587             for (i = 0; i <= len; ++i) {
4588                 SV * const * const svp = av_fetch(av, i, FALSE);
4589                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4590                 ENTER_with_name("smartmatch_array_elem_test");
4591                 SAVETMPS;
4592                 PUSHMARK(SP);
4593                 if (svp)
4594                     PUSHs(*svp);
4595                 PUTBACK;
4596                 c = call_sv(e, G_SCALAR);
4597                 SPAGAIN;
4598                 if (c == 0)
4599                     andedresults = FALSE;
4600                 else
4601                     andedresults = SvTRUEx(POPs) && andedresults;
4602                 FREETMPS;
4603                 LEAVE_with_name("smartmatch_array_elem_test");
4604             }
4605             if (andedresults)
4606                 RETPUSHYES;
4607             else
4608                 RETPUSHNO;
4609         }
4610         else {
4611           sm_any_sub:
4612             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4613             ENTER_with_name("smartmatch_coderef");
4614             SAVETMPS;
4615             PUSHMARK(SP);
4616             PUSHs(d);
4617             PUTBACK;
4618             c = call_sv(e, G_SCALAR);
4619             SPAGAIN;
4620             if (c == 0)
4621                 PUSHs(&PL_sv_no);
4622             else if (SvTEMP(TOPs))
4623                 SvREFCNT_inc_void(TOPs);
4624             FREETMPS;
4625             LEAVE_with_name("smartmatch_coderef");
4626             RETURN;
4627         }
4628     }
4629     /* ~~ %hash */
4630     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4631         if (object_on_left) {
4632             goto sm_any_hash; /* Treat objects like scalars */
4633         }
4634         else if (!SvOK(d)) {
4635             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4636             RETPUSHNO;
4637         }
4638         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4639             /* Check that the key-sets are identical */
4640             HE *he;
4641             HV *other_hv = MUTABLE_HV(SvRV(d));
4642             bool tied = FALSE;
4643             bool other_tied = FALSE;
4644             U32 this_key_count  = 0,
4645                 other_key_count = 0;
4646             HV *hv = MUTABLE_HV(SvRV(e));
4647
4648             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4649             /* Tied hashes don't know how many keys they have. */
4650             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4651                 tied = TRUE;
4652             }
4653             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4654                 HV * const temp = other_hv;
4655                 other_hv = hv;
4656                 hv = temp;
4657                 tied = TRUE;
4658             }
4659             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4660                 other_tied = TRUE;
4661
4662             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4663                 RETPUSHNO;
4664
4665             /* The hashes have the same number of keys, so it suffices
4666                to check that one is a subset of the other. */
4667             (void) hv_iterinit(hv);
4668             while ( (he = hv_iternext(hv)) ) {
4669                 SV *key = hv_iterkeysv(he);
4670
4671                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4672                 ++ this_key_count;
4673
4674                 if(!hv_exists_ent(other_hv, key, 0)) {
4675                     (void) hv_iterinit(hv);     /* reset iterator */
4676                     RETPUSHNO;
4677                 }
4678             }
4679
4680             if (other_tied) {
4681                 (void) hv_iterinit(other_hv);
4682                 while ( hv_iternext(other_hv) )
4683                     ++other_key_count;
4684             }
4685             else
4686                 other_key_count = HvUSEDKEYS(other_hv);
4687
4688             if (this_key_count != other_key_count)
4689                 RETPUSHNO;
4690             else
4691                 RETPUSHYES;
4692         }
4693         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4694             AV * const other_av = MUTABLE_AV(SvRV(d));
4695             const I32 other_len = av_len(other_av) + 1;
4696             I32 i;
4697             HV *hv = MUTABLE_HV(SvRV(e));
4698
4699             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4700             for (i = 0; i < other_len; ++i) {
4701                 SV ** const svp = av_fetch(other_av, i, FALSE);
4702                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4703                 if (svp) {      /* ??? When can this not happen? */
4704                     if (hv_exists_ent(hv, *svp, 0))
4705                         RETPUSHYES;
4706                 }
4707             }
4708             RETPUSHNO;
4709         }
4710         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4711             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4712           sm_regex_hash:
4713             {
4714                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4715                 HE *he;
4716                 HV *hv = MUTABLE_HV(SvRV(e));
4717
4718                 (void) hv_iterinit(hv);
4719                 while ( (he = hv_iternext(hv)) ) {
4720                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4721                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4722                         (void) hv_iterinit(hv);
4723                         destroy_matcher(matcher);
4724                         RETPUSHYES;
4725                     }
4726                 }
4727                 destroy_matcher(matcher);
4728                 RETPUSHNO;
4729             }
4730         }
4731         else {
4732           sm_any_hash:
4733             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4734             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4735                 RETPUSHYES;
4736             else
4737                 RETPUSHNO;
4738         }
4739     }
4740     /* ~~ @array */
4741     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4742         if (object_on_left) {
4743             goto sm_any_array; /* Treat objects like scalars */
4744         }
4745         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4746             AV * const other_av = MUTABLE_AV(SvRV(e));
4747             const I32 other_len = av_len(other_av) + 1;
4748             I32 i;
4749
4750             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4751             for (i = 0; i < other_len; ++i) {
4752                 SV ** const svp = av_fetch(other_av, i, FALSE);
4753
4754                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4755                 if (svp) {      /* ??? When can this not happen? */
4756                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4757                         RETPUSHYES;
4758                 }
4759             }
4760             RETPUSHNO;
4761         }
4762         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4763             AV *other_av = MUTABLE_AV(SvRV(d));
4764             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4765             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4766                 RETPUSHNO;
4767             else {
4768                 I32 i;
4769                 const I32 other_len = av_len(other_av);
4770
4771                 if (NULL == seen_this) {
4772                     seen_this = newHV();
4773                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4774                 }
4775                 if (NULL == seen_other) {
4776                     seen_other = newHV();
4777                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4778                 }
4779                 for(i = 0; i <= other_len; ++i) {
4780                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4781                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4782
4783                     if (!this_elem || !other_elem) {
4784                         if ((this_elem && SvOK(*this_elem))
4785                                 || (other_elem && SvOK(*other_elem)))
4786                             RETPUSHNO;
4787                     }
4788                     else if (hv_exists_ent(seen_this,
4789                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4790                             hv_exists_ent(seen_other,
4791                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4792                     {
4793                         if (*this_elem != *other_elem)
4794                             RETPUSHNO;
4795                     }
4796                     else {
4797                         (void)hv_store_ent(seen_this,
4798                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4799                                 &PL_sv_undef, 0);
4800                         (void)hv_store_ent(seen_other,
4801                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4802                                 &PL_sv_undef, 0);
4803                         PUSHs(*other_elem);
4804                         PUSHs(*this_elem);
4805
4806                         PUTBACK;
4807                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4808                         (void) do_smartmatch(seen_this, seen_other);
4809                         SPAGAIN;
4810                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4811
4812                         if (!SvTRUEx(POPs))
4813                             RETPUSHNO;
4814                     }
4815                 }
4816                 RETPUSHYES;
4817             }
4818         }
4819         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4820             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4821           sm_regex_array:
4822             {
4823                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4824                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4825                 I32 i;
4826
4827                 for(i = 0; i <= this_len; ++i) {
4828                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4829                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4830                     if (svp && matcher_matches_sv(matcher, *svp)) {
4831                         destroy_matcher(matcher);
4832                         RETPUSHYES;
4833                     }
4834                 }
4835                 destroy_matcher(matcher);
4836                 RETPUSHNO;
4837             }
4838         }
4839         else if (!SvOK(d)) {
4840             /* undef ~~ array */
4841             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4842             I32 i;
4843
4844             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4845             for (i = 0; i <= this_len; ++i) {
4846                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4847                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4848                 if (!svp || !SvOK(*svp))
4849                     RETPUSHYES;
4850             }
4851             RETPUSHNO;
4852         }
4853         else {
4854           sm_any_array:
4855             {
4856                 I32 i;
4857                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4858
4859                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4860                 for (i = 0; i <= this_len; ++i) {
4861                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4862                     if (!svp)
4863                         continue;
4864
4865                     PUSHs(d);
4866                     PUSHs(*svp);
4867                     PUTBACK;
4868                     /* infinite recursion isn't supposed to happen here */
4869                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4870                     (void) do_smartmatch(NULL, NULL);
4871                     SPAGAIN;
4872                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4873                     if (SvTRUEx(POPs))
4874                         RETPUSHYES;
4875                 }
4876                 RETPUSHNO;
4877             }
4878         }
4879     }
4880     /* ~~ qr// */
4881     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4882         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4883             SV *t = d; d = e; e = t;
4884             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4885             goto sm_regex_hash;
4886         }
4887         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4888             SV *t = d; d = e; e = t;
4889             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4890             goto sm_regex_array;
4891         }
4892         else {
4893             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4894
4895             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4896             PUTBACK;
4897             PUSHs(matcher_matches_sv(matcher, d)
4898                     ? &PL_sv_yes
4899                     : &PL_sv_no);
4900             destroy_matcher(matcher);
4901             RETURN;
4902         }
4903     }
4904     /* ~~ scalar */
4905     /* See if there is overload magic on left */
4906     else if (object_on_left && SvAMAGIC(d)) {
4907         SV *tmpsv;
4908         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4909         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4910         PUSHs(d); PUSHs(e);
4911         PUTBACK;
4912         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4913         if (tmpsv) {
4914             SPAGAIN;
4915             (void)POPs;
4916             SETs(tmpsv);
4917             RETURN;
4918         }
4919         SP -= 2;
4920         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4921         goto sm_any_scalar;
4922     }
4923     else if (!SvOK(d)) {
4924         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4925         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4926         RETPUSHNO;
4927     }
4928     else
4929   sm_any_scalar:
4930     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4931         DEBUG_M(if (SvNIOK(e))
4932                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4933                 else
4934                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4935         );
4936         /* numeric comparison */
4937         PUSHs(d); PUSHs(e);
4938         PUTBACK;
4939         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4940             (void) Perl_pp_i_eq(aTHX);
4941         else
4942             (void) Perl_pp_eq(aTHX);
4943         SPAGAIN;
4944         if (SvTRUEx(POPs))
4945             RETPUSHYES;
4946         else
4947             RETPUSHNO;
4948     }
4949
4950     /* As a last resort, use string comparison */
4951     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4952     PUSHs(d); PUSHs(e);
4953     PUTBACK;
4954     return Perl_pp_seq(aTHX);
4955 }
4956
4957 PP(pp_enterwhen)
4958 {
4959     dVAR; dSP;
4960     register PERL_CONTEXT *cx;
4961     const I32 gimme = GIMME_V;
4962
4963     /* This is essentially an optimization: if the match
4964        fails, we don't want to push a context and then
4965        pop it again right away, so we skip straight
4966        to the op that follows the leavewhen.
4967        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4968     */
4969     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4970         RETURNOP(cLOGOP->op_other->op_next);
4971
4972     ENTER_with_name("eval");
4973     SAVETMPS;
4974
4975     PUSHBLOCK(cx, CXt_WHEN, SP);
4976     PUSHWHEN(cx);
4977
4978     RETURN;
4979 }
4980
4981 PP(pp_leavewhen)
4982 {
4983     dVAR; dSP;
4984     register PERL_CONTEXT *cx;
4985     I32 gimme __attribute__unused__;
4986     SV **newsp;
4987     PMOP *newpm;
4988
4989     POPBLOCK(cx,newpm);
4990     assert(CxTYPE(cx) == CXt_WHEN);
4991
4992     SP = newsp;
4993     PUTBACK;
4994
4995     PL_curpm = newpm;   /* pop $1 et al */
4996
4997     LEAVE_with_name("eval");
4998     return NORMAL;
4999 }
5000
5001 PP(pp_continue)
5002 {
5003     dVAR;
5004     I32 cxix;
5005     register PERL_CONTEXT *cx;
5006     I32 inner;
5007
5008     cxix = dopoptowhen(cxstack_ix);
5009     if (cxix < 0)
5010         DIE(aTHX_ "Can't \"continue\" outside a when block");
5011     if (cxix < cxstack_ix)
5012         dounwind(cxix);
5013
5014     /* clear off anything above the scope we're re-entering */
5015     inner = PL_scopestack_ix;
5016     TOPBLOCK(cx);
5017     if (PL_scopestack_ix < inner)
5018         leave_scope(PL_scopestack[PL_scopestack_ix]);
5019     PL_curcop = cx->blk_oldcop;
5020     return cx->blk_givwhen.leave_op;
5021 }
5022
5023 PP(pp_break)
5024 {
5025     dVAR;
5026     I32 cxix;
5027     register PERL_CONTEXT *cx;
5028     I32 inner;
5029     dSP;
5030
5031     cxix = dopoptogiven(cxstack_ix);
5032     if (cxix < 0) {
5033         if (PL_op->op_flags & OPf_SPECIAL)
5034             DIE(aTHX_ "Can't use when() outside a topicalizer");
5035         else
5036             DIE(aTHX_ "Can't \"break\" outside a given block");
5037     }
5038     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
5039         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5040
5041     if (cxix < cxstack_ix)
5042         dounwind(cxix);
5043
5044     /* clear off anything above the scope we're re-entering */
5045     inner = PL_scopestack_ix;
5046     TOPBLOCK(cx);
5047     if (PL_scopestack_ix < inner)
5048         leave_scope(PL_scopestack[PL_scopestack_ix]);
5049     PL_curcop = cx->blk_oldcop;
5050
5051     if (CxFOREACH(cx))
5052         return (cx)->blk_loop.my_op->op_nextop;
5053     else
5054         /* RETURNOP calls PUTBACK which restores the old old sp */
5055         RETURNOP(cx->blk_givwhen.leave_op);
5056 }
5057
5058 static MAGIC *
5059 S_doparseform(pTHX_ SV *sv)
5060 {
5061     STRLEN len;
5062     register char *s = SvPV(sv, len);
5063     register char *send;
5064     register char *base = NULL; /* start of current field */
5065     register I32 skipspaces = 0; /* number of contiguous spaces seen */
5066     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5067     bool repeat    = FALSE; /* ~~ seen on this line */
5068     bool postspace = FALSE; /* a text field may need right padding */
5069     U32 *fops;
5070     register U32 *fpc;
5071     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5072     register I32 arg;
5073     bool ischop;            /* it's a ^ rather than a @ */
5074     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5075     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5076     MAGIC *mg = NULL;
5077     SV *sv_copy;
5078
5079     PERL_ARGS_ASSERT_DOPARSEFORM;
5080
5081     if (len == 0)
5082         Perl_croak(aTHX_ "Null picture in formline");
5083
5084     if (SvTYPE(sv) >= SVt_PVMG) {
5085         /* This might, of course, still return NULL.  */
5086         mg = mg_find(sv, PERL_MAGIC_fm);
5087     } else {
5088         sv_upgrade(sv, SVt_PVMG);
5089     }
5090
5091     if (mg) {
5092         /* still the same as previously-compiled string? */
5093         SV *old = mg->mg_obj;
5094         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5095               && len == SvCUR(old)
5096               && strnEQ(SvPVX(old), SvPVX(sv), len)
5097         ) {
5098             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5099             return mg;
5100         }
5101
5102         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5103         Safefree(mg->mg_ptr);
5104         mg->mg_ptr = NULL;
5105         SvREFCNT_dec(old);
5106         mg->mg_obj = NULL;
5107     }
5108     else {
5109         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5110         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5111     }
5112
5113     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5114     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5115     send = s + len;
5116
5117
5118     /* estimate the buffer size needed */
5119     for (base = s; s <= send; s++) {
5120         if (*s == '\n' || *s == '@' || *s == '^')
5121             maxops += 10;
5122     }
5123     s = base;
5124     base = NULL;
5125
5126     Newx(fops, maxops, U32);
5127     fpc = fops;
5128
5129     if (s < send) {
5130         linepc = fpc;
5131         *fpc++ = FF_LINEMARK;
5132         noblank = repeat = FALSE;
5133         base = s;
5134     }
5135
5136     while (s <= send) {
5137         switch (*s++) {
5138         default:
5139             skipspaces = 0;
5140             continue;
5141
5142         case '~':
5143             if (*s == '~') {
5144                 repeat = TRUE;
5145                 skipspaces++;
5146                 s++;
5147             }
5148             noblank = TRUE;
5149             /* FALL THROUGH */
5150         case ' ': case '\t':
5151             skipspaces++;
5152             continue;
5153         case 0:
5154             if (s < send) {
5155                 skipspaces = 0;
5156                 continue;
5157             } /* else FALL THROUGH */
5158         case '\n':
5159             arg = s - base;
5160             skipspaces++;
5161             arg -= skipspaces;
5162             if (arg) {
5163                 if (postspace)
5164                     *fpc++ = FF_SPACE;
5165                 *fpc++ = FF_LITERAL;
5166                 *fpc++ = (U32)arg;
5167             }
5168             postspace = FALSE;
5169             if (s <= send)
5170                 skipspaces--;
5171             if (skipspaces) {
5172                 *fpc++ = FF_SKIP;
5173                 *fpc++ = (U32)skipspaces;
5174             }
5175             skipspaces = 0;
5176             if (s <= send)
5177                 *fpc++ = FF_NEWLINE;
5178             if (noblank) {
5179                 *fpc++ = FF_BLANK;
5180                 if (repeat)
5181                     arg = fpc - linepc + 1;
5182                 else
5183                     arg = 0;
5184                 *fpc++ = (U32)arg;
5185             }
5186             if (s < send) {
5187                 linepc = fpc;
5188                 *fpc++ = FF_LINEMARK;
5189                 noblank = repeat = FALSE;
5190                 base = s;
5191             }
5192             else
5193                 s++;
5194             continue;
5195
5196         case '@':
5197         case '^':
5198             ischop = s[-1] == '^';
5199
5200             if (postspace) {
5201                 *fpc++ = FF_SPACE;
5202                 postspace = FALSE;
5203             }
5204             arg = (s - base) - 1;
5205             if (arg) {
5206                 *fpc++ = FF_LITERAL;
5207                 *fpc++ = (U32)arg;
5208             }
5209
5210             base = s - 1;
5211             *fpc++ = FF_FETCH;
5212             if (*s == '*') { /*  @* or ^*  */
5213                 s++;
5214                 *fpc++ = 2;  /* skip the @* or ^* */
5215                 if (ischop) {
5216                     *fpc++ = FF_LINESNGL;
5217                     *fpc++ = FF_CHOP;
5218                 } else
5219                     *fpc++ = FF_LINEGLOB;
5220             }
5221             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5222                 arg = ischop ? FORM_NUM_BLANK : 0;
5223                 base = s - 1;
5224                 while (*s == '#')
5225                     s++;
5226                 if (*s == '.') {
5227                     const char * const f = ++s;
5228                     while (*s == '#')
5229                         s++;
5230                     arg |= FORM_NUM_POINT + (s - f);
5231                 }
5232                 *fpc++ = s - base;              /* fieldsize for FETCH */
5233                 *fpc++ = FF_DECIMAL;
5234                 *fpc++ = (U32)arg;
5235                 unchopnum |= ! ischop;
5236             }
5237             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5238                 arg = ischop ? FORM_NUM_BLANK : 0;
5239                 base = s - 1;
5240                 s++;                                /* skip the '0' first */
5241                 while (*s == '#')
5242                     s++;
5243                 if (*s == '.') {
5244                     const char * const f = ++s;
5245                     while (*s == '#')
5246                         s++;
5247                     arg |= FORM_NUM_POINT + (s - f);
5248                 }
5249                 *fpc++ = s - base;                /* fieldsize for FETCH */
5250                 *fpc++ = FF_0DECIMAL;
5251                 *fpc++ = (U32)arg;
5252                 unchopnum |= ! ischop;
5253             }
5254             else {                              /* text field */
5255                 I32 prespace = 0;
5256                 bool ismore = FALSE;
5257
5258                 if (*s == '>') {
5259                     while (*++s == '>') ;
5260                     prespace = FF_SPACE;
5261                 }
5262                 else if (*s == '|') {
5263                     while (*++s == '|') ;
5264                     prespace = FF_HALFSPACE;
5265                     postspace = TRUE;
5266                 }
5267                 else {
5268                     if (*s == '<')
5269                         while (*++s == '<') ;
5270                     postspace = TRUE;
5271                 }
5272                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5273                     s += 3;
5274                     ismore = TRUE;
5275                 }
5276                 *fpc++ = s - base;              /* fieldsize for FETCH */
5277
5278                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5279
5280                 if (prespace)
5281                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5282                 *fpc++ = FF_ITEM;
5283                 if (ismore)
5284                     *fpc++ = FF_MORE;
5285                 if (ischop)
5286                     *fpc++ = FF_CHOP;
5287             }
5288             base = s;
5289             skipspaces = 0;
5290             continue;
5291         }
5292     }
5293     *fpc++ = FF_END;
5294
5295     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5296     arg = fpc - fops;
5297
5298     mg->mg_ptr = (char *) fops;
5299     mg->mg_len = arg * sizeof(U32);
5300     mg->mg_obj = sv_copy;
5301     mg->mg_flags |= MGf_REFCOUNTED;
5302
5303     if (unchopnum && repeat)
5304         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5305
5306     return mg;
5307 }
5308
5309
5310 STATIC bool
5311 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5312 {
5313     /* Can value be printed in fldsize chars, using %*.*f ? */
5314     NV pwr = 1;
5315     NV eps = 0.5;
5316     bool res = FALSE;
5317     int intsize = fldsize - (value < 0 ? 1 : 0);
5318
5319     if (frcsize & FORM_NUM_POINT)
5320         intsize--;
5321     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5322     intsize -= frcsize;
5323
5324     while (intsize--) pwr *= 10.0;
5325     while (frcsize--) eps /= 10.0;
5326
5327     if( value >= 0 ){
5328         if (value + eps >= pwr)
5329             res = TRUE;
5330     } else {
5331         if (value - eps <= -pwr)
5332             res = TRUE;
5333     }
5334     return res;
5335 }
5336
5337 static I32
5338 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5339 {
5340     dVAR;
5341     SV * const datasv = FILTER_DATA(idx);
5342     const int filter_has_file = IoLINES(datasv);
5343     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5344     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5345     int status = 0;
5346     SV *upstream;
5347     STRLEN got_len;
5348     char *got_p = NULL;
5349     char *prune_from = NULL;
5350     bool read_from_cache = FALSE;
5351     STRLEN umaxlen;
5352
5353     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5354
5355     assert(maxlen >= 0);
5356     umaxlen = maxlen;
5357
5358     /* I was having segfault trouble under Linux 2.2.5 after a
5359        parse error occured.  (Had to hack around it with a test
5360        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5361        not sure where the trouble is yet.  XXX */
5362
5363     {
5364         SV *const cache = datasv;
5365         if (SvOK(cache)) {
5366             STRLEN cache_len;
5367             const char *cache_p = SvPV(cache, cache_len);
5368             STRLEN take = 0;
5369
5370             if (umaxlen) {
5371                 /* Running in block mode and we have some cached data already.
5372                  */
5373                 if (cache_len >= umaxlen) {
5374                     /* In fact, so much data we don't even need to call
5375                        filter_read.  */
5376                     take = umaxlen;
5377                 }
5378             } else {
5379                 const char *const first_nl =
5380                     (const char *)memchr(cache_p, '\n', cache_len);
5381                 if (first_nl) {
5382                     take = first_nl + 1 - cache_p;
5383                 }
5384             }
5385             if (take) {
5386                 sv_catpvn(buf_sv, cache_p, take);
5387                 sv_chop(cache, cache_p + take);
5388                 /* Definitely not EOF  */
5389                 return 1;
5390             }
5391
5392             sv_catsv(buf_sv, cache);
5393             if (umaxlen) {
5394                 umaxlen -= cache_len;
5395             }
5396             SvOK_off(cache);
5397             read_from_cache = TRUE;
5398         }
5399     }
5400
5401     /* Filter API says that the filter appends to the contents of the buffer.
5402        Usually the buffer is "", so the details don't matter. But if it's not,
5403        then clearly what it contains is already filtered by this filter, so we
5404        don't want to pass it in a second time.
5405        I'm going to use a mortal in case the upstream filter croaks.  */
5406     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5407         ? sv_newmortal() : buf_sv;
5408     SvUPGRADE(upstream, SVt_PV);
5409
5410     if (filter_has_file) {
5411         status = FILTER_READ(idx+1, upstream, 0);
5412     }
5413
5414     if (filter_sub && status >= 0) {
5415         dSP;
5416         int count;
5417
5418         ENTER_with_name("call_filter_sub");
5419         save_gp(PL_defgv, 0);
5420         GvINTRO_off(PL_defgv);
5421         SAVEGENERICSV(GvSV(PL_defgv));
5422         SAVETMPS;
5423         EXTEND(SP, 2);
5424
5425         DEFSV_set(upstream);
5426         SvREFCNT_inc_simple_void_NN(upstream);
5427         PUSHMARK(SP);
5428         mPUSHi(0);
5429         if (filter_state) {
5430             PUSHs(filter_state);
5431         }
5432         PUTBACK;
5433         count = call_sv(filter_sub, G_SCALAR);
5434         SPAGAIN;
5435
5436         if (count > 0) {
5437             SV *out = POPs;
5438             if (SvOK(out)) {
5439                 status = SvIV(out);
5440             }
5441         }
5442
5443         PUTBACK;
5444         FREETMPS;
5445         LEAVE_with_name("call_filter_sub");
5446     }
5447
5448     if(SvOK(upstream)) {
5449         got_p = SvPV(upstream, got_len);
5450         if (umaxlen) {
5451             if (got_len > umaxlen) {
5452                 prune_from = got_p + umaxlen;
5453             }
5454         } else {
5455             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5456             if (first_nl && first_nl + 1 < got_p + got_len) {
5457                 /* There's a second line here... */
5458                 prune_from = first_nl + 1;
5459             }
5460         }
5461     }
5462     if (prune_from) {
5463         /* Oh. Too long. Stuff some in our cache.  */
5464         STRLEN cached_len = got_p + got_len - prune_from;
5465         SV *const cache = datasv;
5466
5467         if (SvOK(cache)) {
5468             /* Cache should be empty.  */
5469             assert(!SvCUR(cache));
5470         }
5471
5472         sv_setpvn(cache, prune_from, cached_len);
5473         /* If you ask for block mode, you may well split UTF-8 characters.
5474            "If it breaks, you get to keep both parts"
5475            (Your code is broken if you  don't put them back together again
5476            before something notices.) */
5477         if (SvUTF8(upstream)) {
5478             SvUTF8_on(cache);
5479         }
5480         SvCUR_set(upstream, got_len - cached_len);
5481         *prune_from = 0;
5482         /* Can't yet be EOF  */
5483         if (status == 0)
5484             status = 1;
5485     }
5486
5487     /* If they are at EOF but buf_sv has something in it, then they may never
5488        have touched the SV upstream, so it may be undefined.  If we naively
5489        concatenate it then we get a warning about use of uninitialised value.
5490     */
5491     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5492         sv_catsv(buf_sv, upstream);
5493     }
5494
5495     if (status <= 0) {
5496         IoLINES(datasv) = 0;
5497         if (filter_state) {
5498             SvREFCNT_dec(filter_state);
5499             IoTOP_GV(datasv) = NULL;
5500         }
5501         if (filter_sub) {
5502             SvREFCNT_dec(filter_sub);
5503             IoBOTTOM_GV(datasv) = NULL;
5504         }
5505         filter_del(S_run_user_filter);
5506     }
5507     if (status == 0 && read_from_cache) {
5508         /* If we read some data from the cache (and by getting here it implies
5509            that we emptied the cache) then we aren't yet at EOF, and mustn't
5510            report that to our caller.  */
5511         return 1;
5512     }
5513     return status;
5514 }
5515
5516 /* perhaps someone can come up with a better name for
5517    this?  it is not really "absolute", per se ... */
5518 static bool
5519 S_path_is_absolute(const char *name)
5520 {
5521     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5522
5523     if (PERL_FILE_IS_ABSOLUTE(name)
5524 #ifdef WIN32
5525         || (*name == '.' && ((name[1] == '/' ||
5526                              (name[1] == '.' && name[2] == '/'))
5527                          || (name[1] == '\\' ||
5528                              ( name[1] == '.' && name[2] == '\\')))
5529             )
5530 #else
5531         || (*name == '.' && (name[1] == '/' ||
5532                              (name[1] == '.' && name[2] == '/')))
5533 #endif
5534          )
5535     {
5536         return TRUE;
5537     }
5538     else
5539         return FALSE;
5540 }
5541
5542 /*
5543  * Local variables:
5544  * c-indentation-style: bsd
5545  * c-basic-offset: 4
5546  * indent-tabs-mode: t
5547  * End:
5548  *
5549  * ex: set ts=8 sts=4 sw=4 noet:
5550  */