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         if (CxONCE(cx) || s < orig ||
 302                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 303                              (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
 304                              ((cx->sb_rflags & REXEC_COPY_STR)
 305                               ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 306                               : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 307         {
 308             SV * const targ = cx->sb_targ;
 309
 310             assert(cx->sb_strend >= s);
 311             if(cx->sb_strend > s) {
 312                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 313                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 314                  else
 315                       sv_catpvn(dstr, s, cx->sb_strend - s);
 316             }
 317             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 318                 cx->sb_rxtainted |= SUBST_TAINT_PAT;
 319
 320 #ifdef PERL_OLD_COPY_ON_WRITE
 321             if (SvIsCOW(targ)) {
 322                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 323             } else
 324 #endif
 325             {
 326                 SvPV_free(targ);
 327             }
 328             SvPV_set(targ, SvPVX(dstr));
 329             SvCUR_set(targ, SvCUR(dstr));
 330             SvLEN_set(targ, SvLEN(dstr));
 331             if (DO_UTF8(dstr))
 332                 SvUTF8_on(targ);
 333             SvPV_set(dstr, NULL);
 334
 335             if (pm->op_pmflags & PMf_NONDESTRUCT)
 336                 PUSHs(targ);
 337             else
 338                 mPUSHi(saviters - 1);
 339
 340             (void)SvPOK_only_UTF8(targ);
 341
 342             /* update the taint state of various various variables in
 343              * preparation for final exit.
 344              * See "how taint works" above pp_subst() */
 345             if (PL_tainting) {
 346                 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 347                     ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 348                                     == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 349                 )
 350                     (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 351
 352                 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
 353                     && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
 354                 )
 355                     SvTAINTED_on(TOPs);  /* taint return value */
 356                 /* needed for mg_set below */
 357                 PL_tainted = cBOOL(cx->sb_rxtainted &
 358                             (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
 359                 SvTAINT(TARG);
 360             }
 361             /* PL_tainted must be correctly set for this mg_set */
 362             SvSETMAGIC(TARG);
 363             TAINT_NOT;
 364             LEAVE_SCOPE(cx->sb_oldsave);
 365             POPSUBST(cx);
 366             RETURNOP(pm->op_next);
 367             /* NOTREACHED */
 368         }
 369         cx->sb_iters = saviters;
 370     }
 371     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 372         m = s;
 373         s = orig;
 374         cx->sb_orig = orig = RX_SUBBEG(rx);
 375         s = orig + (m - s);
 376         cx->sb_strend = s + (cx->sb_strend - m);
 377     }
 378     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 379     if (m > s) {
 380         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 381             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 382         else
 383             sv_catpvn(dstr, s, m-s);
 384     }
 385     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 386     { /* Update the pos() information. */
 387         SV * const sv = cx->sb_targ;
 388         MAGIC *mg;
 389         SvUPGRADE(sv, SVt_PVMG);
 390         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 391 #ifdef PERL_OLD_COPY_ON_WRITE
 392             if (SvIsCOW(sv))
 393                 sv_force_normal_flags(sv, 0);
 394 #endif
 395             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 396                              NULL, 0);
 397         }
 398         mg->mg_len = m - orig;
 399     }
 400     if (old != rx)
 401         (void)ReREFCNT_inc(rx);
 402     /* update the taint state of various various variables in preparation
 403      * for calling the code block.
 404      * See "how taint works" above pp_subst() */
 405     if (PL_tainting) {
 406         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 407             cx->sb_rxtainted |= SUBST_TAINT_PAT;
 408
 409         if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 410             ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 411                             == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 412         )
 413             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 414
 415         if (cx->sb_iters > 1 && (cx->sb_rxtainted &
 416                         (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
 417             SvTAINTED_on(cx->sb_targ);
 418         TAINT_NOT;
 419     }
 420     rxres_save(&cx->sb_rxres, rx);
 421     PL_curpm = pm;
 422     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 423 }
 424
 425 void
 426 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 427 {
 428     UV *p = (UV*)*rsp;
 429     U32 i;
 430
 431     PERL_ARGS_ASSERT_RXRES_SAVE;
 432     PERL_UNUSED_CONTEXT;
 433
 434     if (!p || p[1] < RX_NPARENS(rx)) {
 435 #ifdef PERL_OLD_COPY_ON_WRITE
 436         i = 7 + RX_NPARENS(rx) * 2;
 437 #else
 438         i = 6 + RX_NPARENS(rx) * 2;
 439 #endif
 440         if (!p)
 441             Newx(p, i, UV);
 442         else
 443             Renew(p, i, UV);
 444         *rsp = (void*)p;
 445     }
 446
 447     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 448     RX_MATCH_COPIED_off(rx);
 449
 450 #ifdef PERL_OLD_COPY_ON_WRITE
 451     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 452     RX_SAVED_COPY(rx) = NULL;
 453 #endif
 454
 455     *p++ = RX_NPARENS(rx);
 456
 457     *p++ = PTR2UV(RX_SUBBEG(rx));
 458     *p++ = (UV)RX_SUBLEN(rx);
 459     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 460         *p++ = (UV)RX_OFFS(rx)[i].start;
 461         *p++ = (UV)RX_OFFS(rx)[i].end;
 462     }
 463 }
 464
 465 static void
 466 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 467 {
 468     UV *p = (UV*)*rsp;
 469     U32 i;
 470
 471     PERL_ARGS_ASSERT_RXRES_RESTORE;
 472     PERL_UNUSED_CONTEXT;
 473
 474     RX_MATCH_COPY_FREE(rx);
 475     RX_MATCH_COPIED_set(rx, *p);
 476     *p++ = 0;
 477
 478 #ifdef PERL_OLD_COPY_ON_WRITE
 479     if (RX_SAVED_COPY(rx))
 480         SvREFCNT_dec (RX_SAVED_COPY(rx));
 481     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 482     *p++ = 0;
 483 #endif
 484
 485     RX_NPARENS(rx) = *p++;
 486
 487     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 488     RX_SUBLEN(rx) = (I32)(*p++);
 489     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 490         RX_OFFS(rx)[i].start = (I32)(*p++);
 491         RX_OFFS(rx)[i].end = (I32)(*p++);
 492     }
 493 }
 494
 495 static void
 496 S_rxres_free(pTHX_ void **rsp)
 497 {
 498     UV * const p = (UV*)*rsp;
 499
 500     PERL_ARGS_ASSERT_RXRES_FREE;
 501     PERL_UNUSED_CONTEXT;
 502
 503     if (p) {
 504 #ifdef PERL_POISON
 505         void *tmp = INT2PTR(char*,*p);
 506         Safefree(tmp);
 507         if (*p)
 508             PoisonFree(*p, 1, sizeof(*p));
 509 #else
 510         Safefree(INT2PTR(char*,*p));
 511 #endif
 512 #ifdef PERL_OLD_COPY_ON_WRITE
 513         if (p[1]) {
 514             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 515         }
 516 #endif
 517         Safefree(p);
 518         *rsp = NULL;
 519     }
 520 }
 521
 522 PP(pp_formline)
 523 {
 524     dVAR; dSP; dMARK; dORIGMARK;
 525     register SV * const tmpForm = *++MARK;
 526     SV *formsv;             /* contains text of original format */
 527     register U32 *fpc;      /* format ops program counter */
 528     register char *t;       /* current append position in target string */
 529     const char *f;          /* current position in format string */
 530     register I32 arg;
 531     register SV *sv = NULL; /* current item */
 532     const char *item = NULL;/* string value of current item */
 533     I32 itemsize  = 0;      /* length of current item, possibly truncated */
 534     I32 fieldsize = 0;      /* width of current field */
 535     I32 lines = 0;          /* number of lines that have been output */
 536     bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
 537     const char *chophere = NULL; /* where to chop current item */
 538     char *linemark = NULL;  /* pos of start of line in output */
 539     NV value;
 540     bool gotsome = FALSE;   /* seen at least one non-blank item on this line */
 541     STRLEN len;
 542     STRLEN fudge;           /* estimate of output size in bytes */
 543     bool item_is_utf8 = FALSE;
 544     bool targ_is_utf8 = FALSE;
 545     SV * nsv = NULL;
 546     const char *fmt;
 547     MAGIC *mg = NULL;
 548     U8 *source;             /* source of bytes to append */
 549     STRLEN to_copy;         /* how may bytes to append */
 550
 551     mg = doparseform(tmpForm);
 552
 553     fpc = (U32*)mg->mg_ptr;
 554     /* the actual string the format was compiled from.
 555      * with overload etc, this may not match tmpForm */
 556     formsv = mg->mg_obj;
 557
 558
 559     SvPV_force(PL_formtarget, len);
 560     if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
 561         SvTAINTED_on(PL_formtarget);
 562     if (DO_UTF8(PL_formtarget))
 563         targ_is_utf8 = TRUE;
 564     fudge = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
 565     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 566     t += len;
 567     f = SvPV_const(formsv, len);
 568
 569     for (;;) {
 570         DEBUG_f( {
 571             const char *name = "???";
 572             arg = -1;
 573             switch (*fpc) {
 574             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 575             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 576             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 577             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 578             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 579
 580             case FF_CHECKNL:    name = "CHECKNL";       break;
 581             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 582             case FF_SPACE:      name = "SPACE";         break;
 583             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 584             case FF_ITEM:       name = "ITEM";          break;
 585             case FF_CHOP:       name = "CHOP";          break;
 586             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 587             case FF_NEWLINE:    name = "NEWLINE";       break;
 588             case FF_MORE:       name = "MORE";          break;
 589             case FF_LINEMARK:   name = "LINEMARK";      break;
 590             case FF_END:        name = "END";           break;
 591             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 592             case FF_LINESNGL:   name = "LINESNGL";      break;
 593             }
 594             if (arg >= 0)
 595                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 596             else
 597                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 598         } );
 599         switch (*fpc++) {
 600         case FF_LINEMARK:
 601             linemark = t;
 602             lines++;
 603             gotsome = FALSE;
 604             break;
 605
 606         case FF_LITERAL:
 607             arg = *fpc++;
 608             if (targ_is_utf8 && !SvUTF8(formsv)) {
 609                 char *s;
 610                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 611                 *t = '\0';
 612
 613                 /* this is an unrolled sv_catpvn_utf8_upgrade(),
 614                  * but with the addition of s/~/ /g */
 615                 if (!(nsv))
 616                     nsv = newSVpvn_flags(f, arg, SVs_TEMP);
 617                 else
 618                     sv_setpvn(nsv, f, arg);
 619                 SvUTF8_off(nsv);
 620                 for (s = SvPVX(nsv); s <= SvEND(nsv); s++)
 621                     if (*s == '~')
 622                         *s = ' ';
 623                 sv_utf8_upgrade(nsv);
 624                 sv_catsv(PL_formtarget, nsv);
 625
 626                 t = SvEND(PL_formtarget);
 627                 f += arg;
 628                 break;
 629             }
 630             if (!targ_is_utf8 && DO_UTF8(formsv)) {
 631                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 632                 *t = '\0';
 633                 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
 634                 t = SvEND(PL_formtarget);
 635                 targ_is_utf8 = TRUE;
 636             }
 637             while (arg--) {
 638                 *t++ = (*f == '~') ? ' ' : *f;
 639                 f++;
 640             }
 641             break;
 642
 643         case FF_SKIP:
 644             f += *fpc++;
 645             break;
 646
 647         case FF_FETCH:
 648             arg = *fpc++;
 649             f += arg;
 650             fieldsize = arg;
 651
 652             if (MARK < SP)
 653                 sv = *++MARK;
 654             else {
 655                 sv = &PL_sv_no;
 656                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 657             }
 658             if (SvTAINTED(sv))
 659                 SvTAINTED_on(PL_formtarget);
 660             break;
 661
 662         case FF_CHECKNL:
 663             {
 664                 const char *send;
 665                 const char *s = item = SvPV_const(sv, len);
 666                 itemsize = len;
 667                 if (DO_UTF8(sv)) {
 668                     itemsize = sv_len_utf8(sv);
 669                     if (itemsize != (I32)len) {
 670                         I32 itembytes;
 671                         if (itemsize > fieldsize) {
 672                             itemsize = fieldsize;
 673                             itembytes = itemsize;
 674                             sv_pos_u2b(sv, &itembytes, 0);
 675                         }
 676                         else
 677                             itembytes = len;
 678                         send = chophere = s + itembytes;
 679                         while (s < send) {
 680                             if (*s & ~31)
 681                                 gotsome = TRUE;
 682                             else if (*s == '\n')
 683                                 break;
 684                             s++;
 685                         }
 686                         item_is_utf8 = TRUE;
 687                         itemsize = s - item;
 688                         sv_pos_b2u(sv, &itemsize);
 689                         break;
 690                     }
 691                 }
 692                 item_is_utf8 = FALSE;
 693                 if (itemsize > fieldsize)
 694                     itemsize = fieldsize;
 695                 send = chophere = s + itemsize;
 696                 while (s < send) {
 697                     if (*s & ~31)
 698                         gotsome = TRUE;
 699                     else if (*s == '\n')
 700                         break;
 701                     s++;
 702                 }
 703                 itemsize = s - item;
 704                 break;
 705             }
 706
 707         case FF_CHECKCHOP:
 708             {
 709                 const char *s = item = SvPV_const(sv, len);
 710                 itemsize = len;
 711                 if (DO_UTF8(sv)) {
 712                     itemsize = sv_len_utf8(sv);
 713                     if (itemsize != (I32)len) {
 714                         I32 itembytes;
 715                         if (itemsize <= fieldsize) {
 716                             const char *send = chophere = s + itemsize;
 717                             while (s < send) {
 718                                 if (*s == '\r') {
 719                                     itemsize = s - item;
 720                                     chophere = s;
 721                                     break;
 722                                 }
 723                                 if (*s++ & ~31)
 724                                     gotsome = TRUE;
 725                             }
 726                         }
 727                         else {
 728                             const char *send;
 729                             itemsize = fieldsize;
 730                             itembytes = itemsize;
 731                             sv_pos_u2b(sv, &itembytes, 0);
 732                             send = chophere = s + itembytes;
 733                             while (s < send || (s == send && isSPACE(*s))) {
 734                                 if (isSPACE(*s)) {
 735                                     if (chopspace)
 736                                         chophere = s;
 737                                     if (*s == '\r')
 738                                         break;
 739                                 }
 740                                 else {
 741                                     if (*s & ~31)
 742                                         gotsome = TRUE;
 743                                     if (strchr(PL_chopset, *s))
 744                                         chophere = s + 1;
 745                                 }
 746                                 s++;
 747                             }
 748                             itemsize = chophere - item;
 749                             sv_pos_b2u(sv, &itemsize);
 750                         }
 751                         item_is_utf8 = TRUE;
 752                         break;
 753                     }
 754                 }
 755                 item_is_utf8 = FALSE;
 756                 if (itemsize <= fieldsize) {
 757                     const char *const send = chophere = s + itemsize;
 758                     while (s < send) {
 759                         if (*s == '\r') {
 760                             itemsize = s - item;
 761                             chophere = s;
 762                             break;
 763                         }
 764                         if (*s++ & ~31)
 765                             gotsome = TRUE;
 766                     }
 767                 }
 768                 else {
 769                     const char *send;
 770                     itemsize = fieldsize;
 771                     send = chophere = s + itemsize;
 772                     while (s < send || (s == send && isSPACE(*s))) {
 773                         if (isSPACE(*s)) {
 774                             if (chopspace)
 775                                 chophere = s;
 776                             if (*s == '\r')
 777                                 break;
 778                         }
 779                         else {
 780                             if (*s & ~31)
 781                                 gotsome = TRUE;
 782                             if (strchr(PL_chopset, *s))
 783                                 chophere = s + 1;
 784                         }
 785                         s++;
 786                     }
 787                     itemsize = chophere - item;
 788                 }
 789                 break;
 790             }
 791
 792         case FF_SPACE:
 793             arg = fieldsize - itemsize;
 794             if (arg) {
 795                 fieldsize -= arg;
 796                 while (arg-- > 0)
 797                     *t++ = ' ';
 798             }
 799             break;
 800
 801         case FF_HALFSPACE:
 802             arg = fieldsize - itemsize;
 803             if (arg) {
 804                 arg /= 2;
 805                 fieldsize -= arg;
 806                 while (arg-- > 0)
 807                     *t++ = ' ';
 808             }
 809             break;
 810
 811         case FF_ITEM:
 812             {
 813                 const char *s = item;
 814                 arg = itemsize;
 815                 if (item_is_utf8) {
 816                     if (!targ_is_utf8) {
 817                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 818                         *t = '\0';
 819                         sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
 820                                                                     fudge + 1);
 821                         t = SvEND(PL_formtarget);
 822                         targ_is_utf8 = TRUE;
 823                     }
 824                     while (arg--) {
 825                         if (UTF8_IS_CONTINUED(*s)) {
 826                             STRLEN skip = UTF8SKIP(s);
 827                             switch (skip) {
 828                             default:
 829                                 Move(s,t,skip,char);
 830                                 s += skip;
 831                                 t += skip;
 832                                 break;
 833                             case 7: *t++ = *s++;
 834                             case 6: *t++ = *s++;
 835                             case 5: *t++ = *s++;
 836                             case 4: *t++ = *s++;
 837                             case 3: *t++ = *s++;
 838                             case 2: *t++ = *s++;
 839                             case 1: *t++ = *s++;
 840                             }
 841                         }
 842                         else {
 843                             if ( !((*t++ = *s++) & ~31) )
 844                                 t[-1] = ' ';
 845                         }
 846                     }
 847                     break;
 848                 }
 849                 if (targ_is_utf8 && !item_is_utf8) {
 850                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 851                     *t = '\0';
 852                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 853                     for (; t < SvEND(PL_formtarget); t++) {
 854 #ifdef EBCDIC
 855                         const int ch = *t;
 856                         if (iscntrl(ch))
 857 #else
 858                             if (!(*t & ~31))
 859 #endif
 860                                 *t = ' ';
 861                     }
 862                     break;
 863                 }
 864                 while (arg--) {
 865 #ifdef EBCDIC
 866                     const int ch = *t++ = *s++;
 867                     if (iscntrl(ch))
 868 #else
 869                     if ( !((*t++ = *s++) & ~31) )
 870 #endif
 871                             t[-1] = ' ';
 872                 }
 873                 break;
 874             }
 875
 876         case FF_CHOP:
 877             {
 878                 const char *s = chophere;
 879                 if (chopspace) {
 880                     while (isSPACE(*s))
 881                         s++;
 882                 }
 883                 sv_chop(sv,s);
 884                 SvSETMAGIC(sv);
 885                 break;
 886             }
 887
 888         case FF_LINESNGL:
 889             chopspace = 0;
 890         case FF_LINEGLOB:
 891             {
 892                 const bool oneline = fpc[-1] == FF_LINESNGL;
 893                 const char *s = item = SvPV_const(sv, len);
 894                 const char *const send = s + len;
 895
 896                 item_is_utf8 = DO_UTF8(sv);
 897                 itemsize = len;
 898                 if (!itemsize)
 899                     break;
 900                 gotsome = TRUE;
 901                 chophere = s + itemsize;
 902                 source = (U8 *) s;
 903                 to_copy = len;
 904                 while (s < send) {
 905                     if (*s++ == '\n') {
 906                         if (oneline) {
 907                             to_copy = s - SvPVX_const(sv) - 1;
 908                             chophere = s;
 909                             break;
 910                         } else {
 911                             if (s == send) {
 912                                 itemsize--;
 913                                 to_copy--;
 914                             } else
 915                                 lines++;
 916                         }
 917                     }
 918                 }
 919             }
 920
 921             {
 922                 U8 *tmp = NULL;
 923                 if (targ_is_utf8 && !item_is_utf8) {
 924                     source = tmp = bytes_to_utf8(source, &to_copy);
 925                     SvCUR_set(PL_formtarget,
 926                               t - SvPVX_const(PL_formtarget));
 927                 } else {
 928                     if (item_is_utf8 && !targ_is_utf8) {
 929                         /* Upgrade targ to UTF8, and then we reduce it to
 930                            a problem we have a simple solution for.  */
 931                         SvCUR_set(PL_formtarget,
 932                                   t - SvPVX_const(PL_formtarget));
 933                         targ_is_utf8 = TRUE;
 934                         /* Don't need get magic.  */
 935                         sv_utf8_upgrade_nomg(PL_formtarget);
 936                     } else {
 937                         SvCUR_set(PL_formtarget,
 938                                   t - SvPVX_const(PL_formtarget));
 939                     }
 940
 941                     /* Easy. They agree.  */
 942                     assert (item_is_utf8 == targ_is_utf8);
 943                 }
 944                 SvGROW(PL_formtarget,
 945                        SvCUR(PL_formtarget) + to_copy + fudge + 1);
 946                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 947
 948                 Copy(source, t, to_copy, char);
 949                 t += to_copy;
 950                 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 951                 if (item_is_utf8) {
 952                     if (SvGMAGICAL(sv)) {
 953                         /* Mustn't call sv_pos_b2u() as it does a second
 954                            mg_get(). Is this a bug? Do we need a _flags()
 955                            variant? */
 956                         itemsize = utf8_length(source, source + itemsize);
 957                     } else {
 958                         sv_pos_b2u(sv, &itemsize);
 959                     }
 960                     assert(!tmp);
 961                 } else if (tmp) {
 962                     Safefree(tmp);
 963                 }
 964                 break;
 965             }
 966
 967         case FF_0DECIMAL:
 968             arg = *fpc++;
 969 #if defined(USE_LONG_DOUBLE)
 970             fmt = (const char *)
 971                 ((arg & 256) ?
 972                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 973 #else
 974             fmt = (const char *)
 975                 ((arg & 256) ?
 976                  "%#0*.*f"              : "%0*.*f");
 977 #endif
 978             goto ff_dec;
 979         case FF_DECIMAL:
 980             arg = *fpc++;
 981 #if defined(USE_LONG_DOUBLE)
 982             fmt = (const char *)
 983                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 984 #else
 985             fmt = (const char *)
 986                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 987 #endif
 988         ff_dec:
 989             /* If the field is marked with ^ and the value is undefined,
 990                blank it out. */
 991             if ((arg & 512) && !SvOK(sv)) {
 992                 arg = fieldsize;
 993                 while (arg--)
 994                     *t++ = ' ';
 995                 break;
 996             }
 997             gotsome = TRUE;
 998             value = SvNV(sv);
 999             /* overflow evidence */
1000             if (num_overflow(value, fieldsize, arg)) {
1001                 arg = fieldsize;
1002                 while (arg--)
1003                     *t++ = '#';
1004                 break;
1005             }
1006             /* Formats aren't yet marked for locales, so assume "yes". */
1007             {
1008                 STORE_NUMERIC_STANDARD_SET_LOCAL();
1009                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
1010                 RESTORE_NUMERIC_STANDARD();
1011             }
1012             t += fieldsize;
1013             break;
1014
1015         case FF_NEWLINE:
1016             f++;
1017             while (t-- > linemark && *t == ' ') ;
1018             t++;
1019             *t++ = '\n';
1020             break;
1021
1022         case FF_BLANK:
1023             arg = *fpc++;
1024             if (gotsome) {
1025                 if (arg) {              /* repeat until fields exhausted? */
1026                     fpc--;
1027                     goto end;
1028                 }
1029             }
1030             else {
1031                 t = linemark;
1032                 lines--;
1033             }
1034             break;
1035
1036         case FF_MORE:
1037             {
1038                 const char *s = chophere;
1039                 const char *send = item + len;
1040                 if (chopspace) {
1041                     while (isSPACE(*s) && (s < send))
1042                         s++;
1043                 }
1044                 if (s < send) {
1045                     char *s1;
1046                     arg = fieldsize - itemsize;
1047                     if (arg) {
1048                         fieldsize -= arg;
1049                         while (arg-- > 0)
1050                             *t++ = ' ';
1051                     }
1052                     s1 = t - 3;
1053                     if (strnEQ(s1,"   ",3)) {
1054                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1055                             s1--;
1056                     }
1057                     *s1++ = '.';
1058                     *s1++ = '.';
1059                     *s1++ = '.';
1060                 }
1061                 break;
1062             }
1063         case FF_END:
1064         end:
1065             *t = '\0';
1066             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1067             if (targ_is_utf8)
1068                 SvUTF8_on(PL_formtarget);
1069             FmLINES(PL_formtarget) += lines;
1070             SP = ORIGMARK;
1071             if (fpc[-1] == FF_BLANK)
1072                 RETURNOP(cLISTOP->op_first);
1073             else
1074                 RETPUSHYES;
1075         }
1076     }
1077 }
1078
1079 PP(pp_grepstart)
1080 {
1081     dVAR; dSP;
1082     SV *src;
1083
1084     if (PL_stack_base + *PL_markstack_ptr == SP) {
1085         (void)POPMARK;
1086         if (GIMME_V == G_SCALAR)
1087             mXPUSHi(0);
1088         RETURNOP(PL_op->op_next->op_next);
1089     }
1090     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1091     Perl_pp_pushmark(aTHX);                             /* push dst */
1092     Perl_pp_pushmark(aTHX);                             /* push src */
1093     ENTER_with_name("grep");                                    /* enter outer scope */
1094
1095     SAVETMPS;
1096     if (PL_op->op_private & OPpGREP_LEX)
1097         SAVESPTR(PAD_SVl(PL_op->op_targ));
1098     else
1099         SAVE_DEFSV;
1100     ENTER_with_name("grep_item");                                       /* enter inner scope */
1101     SAVEVPTR(PL_curpm);
1102
1103     src = PL_stack_base[*PL_markstack_ptr];
1104     SvTEMP_off(src);
1105     if (PL_op->op_private & OPpGREP_LEX)
1106         PAD_SVl(PL_op->op_targ) = src;
1107     else
1108         DEFSV_set(src);
1109
1110     PUTBACK;
1111     if (PL_op->op_type == OP_MAPSTART)
1112         Perl_pp_pushmark(aTHX);                 /* push top */
1113     return ((LOGOP*)PL_op->op_next)->op_other;
1114 }
1115
1116 PP(pp_mapwhile)
1117 {
1118     dVAR; dSP;
1119     const I32 gimme = GIMME_V;
1120     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1121     I32 count;
1122     I32 shift;
1123     SV** src;
1124     SV** dst;
1125
1126     /* first, move source pointer to the next item in the source list */
1127     ++PL_markstack_ptr[-1];
1128
1129     /* if there are new items, push them into the destination list */
1130     if (items && gimme != G_VOID) {
1131         /* might need to make room back there first */
1132         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1133             /* XXX this implementation is very pessimal because the stack
1134              * is repeatedly extended for every set of items.  Is possible
1135              * to do this without any stack extension or copying at all
1136              * by maintaining a separate list over which the map iterates
1137              * (like foreach does). --gsar */
1138
1139             /* everything in the stack after the destination list moves
1140              * towards the end the stack by the amount of room needed */
1141             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1142
1143             /* items to shift up (accounting for the moved source pointer) */
1144             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1145
1146             /* This optimization is by Ben Tilly and it does
1147              * things differently from what Sarathy (gsar)
1148              * is describing.  The downside of this optimization is
1149              * that leaves "holes" (uninitialized and hopefully unused areas)
1150              * to the Perl stack, but on the other hand this
1151              * shouldn't be a problem.  If Sarathy's idea gets
1152              * implemented, this optimization should become
1153              * irrelevant.  --jhi */
1154             if (shift < count)
1155                 shift = count; /* Avoid shifting too often --Ben Tilly */
1156
1157             EXTEND(SP,shift);
1158             src = SP;
1159             dst = (SP += shift);
1160             PL_markstack_ptr[-1] += shift;
1161             *PL_markstack_ptr += shift;
1162             while (count--)
1163                 *dst-- = *src--;
1164         }
1165         /* copy the new items down to the destination list */
1166         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1167         if (gimme == G_ARRAY) {
1168             /* add returned items to the collection (making mortal copies
1169              * if necessary), then clear the current temps stack frame
1170              * *except* for those items. We do this splicing the items
1171              * into the start of the tmps frame (so some items may be on
1172              * the tmps stack twice), then moving PL_tmps_floor above
1173              * them, then freeing the frame. That way, the only tmps that
1174              * accumulate over iterations are the return values for map.
1175              * We have to do to this way so that everything gets correctly
1176              * freed if we die during the map.
1177              */
1178             I32 tmpsbase;
1179             I32 i = items;
1180             /* make space for the slice */
1181             EXTEND_MORTAL(items);
1182             tmpsbase = PL_tmps_floor + 1;
1183             Move(PL_tmps_stack + tmpsbase,
1184                  PL_tmps_stack + tmpsbase + items,
1185                  PL_tmps_ix - PL_tmps_floor,
1186                  SV*);
1187             PL_tmps_ix += items;
1188
1189             while (i-- > 0) {
1190                 SV *sv = POPs;
1191                 if (!SvTEMP(sv))
1192                     sv = sv_mortalcopy(sv);
1193                 *dst-- = sv;
1194                 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1195             }
1196             /* clear the stack frame except for the items */
1197             PL_tmps_floor += items;
1198             FREETMPS;
1199             /* FREETMPS may have cleared the TEMP flag on some of the items */
1200             i = items;
1201             while (i-- > 0)
1202                 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1203         }
1204         else {
1205             /* scalar context: we don't care about which values map returns
1206              * (we use undef here). And so we certainly don't want to do mortal
1207              * copies of meaningless values. */
1208             while (items-- > 0) {
1209                 (void)POPs;
1210                 *dst-- = &PL_sv_undef;
1211             }
1212             FREETMPS;
1213         }
1214     }
1215     else {
1216         FREETMPS;
1217     }
1218     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1219
1220     /* All done yet? */
1221     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1222
1223         (void)POPMARK;                          /* pop top */
1224         LEAVE_with_name("grep");                                        /* exit outer scope */
1225         (void)POPMARK;                          /* pop src */
1226         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1227         (void)POPMARK;                          /* pop dst */
1228         SP = PL_stack_base + POPMARK;           /* pop original mark */
1229         if (gimme == G_SCALAR) {
1230             if (PL_op->op_private & OPpGREP_LEX) {
1231                 SV* sv = sv_newmortal();
1232                 sv_setiv(sv, items);
1233                 PUSHs(sv);
1234             }
1235             else {
1236                 dTARGET;
1237                 XPUSHi(items);
1238             }
1239         }
1240         else if (gimme == G_ARRAY)
1241             SP += items;
1242         RETURN;
1243     }
1244     else {
1245         SV *src;
1246
1247         ENTER_with_name("grep_item");                                   /* enter inner scope */
1248         SAVEVPTR(PL_curpm);
1249
1250         /* set $_ to the new source item */
1251         src = PL_stack_base[PL_markstack_ptr[-1]];
1252         SvTEMP_off(src);
1253         if (PL_op->op_private & OPpGREP_LEX)
1254             PAD_SVl(PL_op->op_targ) = src;
1255         else
1256             DEFSV_set(src);
1257
1258         RETURNOP(cLOGOP->op_other);
1259     }
1260 }
1261
1262 /* Range stuff. */
1263
1264 PP(pp_range)
1265 {
1266     dVAR;
1267     if (GIMME == G_ARRAY)
1268         return NORMAL;
1269     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1270         return cLOGOP->op_other;
1271     else
1272         return NORMAL;
1273 }
1274
1275 PP(pp_flip)
1276 {
1277     dVAR;
1278     dSP;
1279
1280     if (GIMME == G_ARRAY) {
1281         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1282     }
1283     else {
1284         dTOPss;
1285         SV * const targ = PAD_SV(PL_op->op_targ);
1286         int flip = 0;
1287
1288         if (PL_op->op_private & OPpFLIP_LINENUM) {
1289             if (GvIO(PL_last_in_gv)) {
1290                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1291             }
1292             else {
1293                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1294                 if (gv && GvSV(gv))
1295                     flip = SvIV(sv) == SvIV(GvSV(gv));
1296             }
1297         } else {
1298             flip = SvTRUE(sv);
1299         }
1300         if (flip) {
1301             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1302             if (PL_op->op_flags & OPf_SPECIAL) {
1303                 sv_setiv(targ, 1);
1304                 SETs(targ);
1305                 RETURN;
1306             }
1307             else {
1308                 sv_setiv(targ, 0);
1309                 SP--;
1310                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1311             }
1312         }
1313         sv_setpvs(TARG, "");
1314         SETs(targ);
1315         RETURN;
1316     }
1317 }
1318
1319 /* This code tries to decide if "$left .. $right" should use the
1320    magical string increment, or if the range is numeric (we make
1321    an exception for .."0" [#18165]). AMS 20021031. */
1322
1323 #define RANGE_IS_NUMERIC(left,right) ( \
1324         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1325         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1326         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1327           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1328          && (!SvOK(right) || looks_like_number(right))))
1329
1330 PP(pp_flop)
1331 {
1332     dVAR; dSP;
1333
1334     if (GIMME == G_ARRAY) {
1335         dPOPPOPssrl;
1336
1337         SvGETMAGIC(left);
1338         SvGETMAGIC(right);
1339
1340         if (RANGE_IS_NUMERIC(left,right)) {
1341             register IV i, j;
1342             IV max;
1343             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1344                 (SvOK(right) && SvNV(right) > IV_MAX))
1345                 DIE(aTHX_ "Range iterator outside integer range");
1346             i = SvIV(left);
1347             max = SvIV(right);
1348             if (max >= i) {
1349                 j = max - i + 1;
1350                 EXTEND_MORTAL(j);
1351                 EXTEND(SP, j);
1352             }
1353             else
1354                 j = 0;
1355             while (j--) {
1356                 SV * const sv = sv_2mortal(newSViv(i++));
1357                 PUSHs(sv);
1358             }
1359         }
1360         else {
1361             SV * const final = sv_mortalcopy(right);
1362             STRLEN len;
1363             const char * const tmps = SvPV_const(final, len);
1364
1365             SV *sv = sv_mortalcopy(left);
1366             SvPV_force_nolen(sv);
1367             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1368                 XPUSHs(sv);
1369                 if (strEQ(SvPVX_const(sv),tmps))
1370                     break;
1371                 sv = sv_2mortal(newSVsv(sv));
1372                 sv_inc(sv);
1373             }
1374         }
1375     }
1376     else {
1377         dTOPss;
1378         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1379         int flop = 0;
1380         sv_inc(targ);
1381
1382         if (PL_op->op_private & OPpFLIP_LINENUM) {
1383             if (GvIO(PL_last_in_gv)) {
1384                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1385             }
1386             else {
1387                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1388                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1389             }
1390         }
1391         else {
1392             flop = SvTRUE(sv);
1393         }
1394
1395         if (flop) {
1396             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1397             sv_catpvs(targ, "E0");
1398         }
1399         SETs(targ);
1400     }
1401
1402     RETURN;
1403 }
1404
1405 /* Control. */
1406
1407 static const char * const context_name[] = {
1408     "pseudo-block",
1409     NULL, /* CXt_WHEN never actually needs "block" */
1410     NULL, /* CXt_BLOCK never actually needs "block" */
1411     NULL, /* CXt_GIVEN never actually needs "block" */
1412     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1413     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1414     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1415     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1416     "subroutine",
1417     "format",
1418     "eval",
1419     "substitution",
1420 };
1421
1422 STATIC I32
1423 S_dopoptolabel(pTHX_ const char *label)
1424 {
1425     dVAR;
1426     register I32 i;
1427
1428     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1429
1430     for (i = cxstack_ix; i >= 0; i--) {
1431         register const PERL_CONTEXT * const cx = &cxstack[i];
1432         switch (CxTYPE(cx)) {
1433         case CXt_SUBST:
1434         case CXt_SUB:
1435         case CXt_FORMAT:
1436         case CXt_EVAL:
1437         case CXt_NULL:
1438             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1439                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1440             if (CxTYPE(cx) == CXt_NULL)
1441                 return -1;
1442             break;
1443         case CXt_LOOP_LAZYIV:
1444         case CXt_LOOP_LAZYSV:
1445         case CXt_LOOP_FOR:
1446         case CXt_LOOP_PLAIN:
1447           {
1448             const char *cx_label = CxLABEL(cx);
1449             if (!cx_label || strNE(label, cx_label) ) {
1450                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1451                         (long)i, cx_label));
1452                 continue;
1453             }
1454             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1455             return i;
1456           }
1457         }
1458     }
1459     return i;
1460 }
1461
1462
1463
1464 I32
1465 Perl_dowantarray(pTHX)
1466 {
1467     dVAR;
1468     const I32 gimme = block_gimme();
1469     return (gimme == G_VOID) ? G_SCALAR : gimme;
1470 }
1471
1472 I32
1473 Perl_block_gimme(pTHX)
1474 {
1475     dVAR;
1476     const I32 cxix = dopoptosub(cxstack_ix);
1477     if (cxix < 0)
1478         return G_VOID;
1479
1480     switch (cxstack[cxix].blk_gimme) {
1481     case G_VOID:
1482         return G_VOID;
1483     case G_SCALAR:
1484         return G_SCALAR;
1485     case G_ARRAY:
1486         return G_ARRAY;
1487     default:
1488         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1489         /* NOTREACHED */
1490         return 0;
1491     }
1492 }
1493
1494 I32
1495 Perl_is_lvalue_sub(pTHX)
1496 {
1497     dVAR;
1498     const I32 cxix = dopoptosub(cxstack_ix);
1499     assert(cxix >= 0);  /* We should only be called from inside subs */
1500
1501     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1502         return CxLVAL(cxstack + cxix);
1503     else
1504         return 0;
1505 }
1506
1507 STATIC I32
1508 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1509 {
1510     dVAR;
1511     I32 i;
1512
1513     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1514
1515     for (i = startingblock; i >= 0; i--) {
1516         register const PERL_CONTEXT * const cx = &cxstk[i];
1517         switch (CxTYPE(cx)) {
1518         default:
1519             continue;
1520         case CXt_EVAL:
1521         case CXt_SUB:
1522         case CXt_FORMAT:
1523             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1524             return i;
1525         }
1526     }
1527     return i;
1528 }
1529
1530 STATIC I32
1531 S_dopoptoeval(pTHX_ I32 startingblock)
1532 {
1533     dVAR;
1534     I32 i;
1535     for (i = startingblock; i >= 0; i--) {
1536         register const PERL_CONTEXT *cx = &cxstack[i];
1537         switch (CxTYPE(cx)) {
1538         default:
1539             continue;
1540         case CXt_EVAL:
1541             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1542             return i;
1543         }
1544     }
1545     return i;
1546 }
1547
1548 STATIC I32
1549 S_dopoptoloop(pTHX_ I32 startingblock)
1550 {
1551     dVAR;
1552     I32 i;
1553     for (i = startingblock; i >= 0; i--) {
1554         register const PERL_CONTEXT * const cx = &cxstack[i];
1555         switch (CxTYPE(cx)) {
1556         case CXt_SUBST:
1557         case CXt_SUB:
1558         case CXt_FORMAT:
1559         case CXt_EVAL:
1560         case CXt_NULL:
1561             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1562                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1563             if ((CxTYPE(cx)) == CXt_NULL)
1564                 return -1;
1565             break;
1566         case CXt_LOOP_LAZYIV:
1567         case CXt_LOOP_LAZYSV:
1568         case CXt_LOOP_FOR:
1569         case CXt_LOOP_PLAIN:
1570             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1571             return i;
1572         }
1573     }
1574     return i;
1575 }
1576
1577 STATIC I32
1578 S_dopoptogiven(pTHX_ I32 startingblock)
1579 {
1580     dVAR;
1581     I32 i;
1582     for (i = startingblock; i >= 0; i--) {
1583         register const PERL_CONTEXT *cx = &cxstack[i];
1584         switch (CxTYPE(cx)) {
1585         default:
1586             continue;
1587         case CXt_GIVEN:
1588             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1589             return i;
1590         case CXt_LOOP_PLAIN:
1591             assert(!CxFOREACHDEF(cx));
1592             break;
1593         case CXt_LOOP_LAZYIV:
1594         case CXt_LOOP_LAZYSV:
1595         case CXt_LOOP_FOR:
1596             if (CxFOREACHDEF(cx)) {
1597                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1598                 return i;
1599             }
1600         }
1601     }
1602     return i;
1603 }
1604
1605 STATIC I32
1606 S_dopoptowhen(pTHX_ I32 startingblock)
1607 {
1608     dVAR;
1609     I32 i;
1610     for (i = startingblock; i >= 0; i--) {
1611         register const PERL_CONTEXT *cx = &cxstack[i];
1612         switch (CxTYPE(cx)) {
1613         default:
1614             continue;
1615         case CXt_WHEN:
1616             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1617             return i;
1618         }
1619     }
1620     return i;
1621 }
1622
1623 void
1624 Perl_dounwind(pTHX_ I32 cxix)
1625 {
1626     dVAR;
1627     I32 optype;
1628
1629     while (cxstack_ix > cxix) {
1630         SV *sv;
1631         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1632         DEBUG_CX("UNWIND");                                             \
1633         /* Note: we don't need to restore the base context info till the end. */
1634         switch (CxTYPE(cx)) {
1635         case CXt_SUBST:
1636             POPSUBST(cx);
1637             continue;  /* not break */
1638         case CXt_SUB:
1639             POPSUB(cx,sv);
1640             LEAVESUB(sv);
1641             break;
1642         case CXt_EVAL:
1643             POPEVAL(cx);
1644             break;
1645         case CXt_LOOP_LAZYIV:
1646         case CXt_LOOP_LAZYSV:
1647         case CXt_LOOP_FOR:
1648         case CXt_LOOP_PLAIN:
1649             POPLOOP(cx);
1650             break;
1651         case CXt_NULL:
1652             break;
1653         case CXt_FORMAT:
1654             POPFORMAT(cx);
1655             break;
1656         }
1657         cxstack_ix--;
1658     }
1659     PERL_UNUSED_VAR(optype);
1660 }
1661
1662 void
1663 Perl_qerror(pTHX_ SV *err)
1664 {
1665     dVAR;
1666
1667     PERL_ARGS_ASSERT_QERROR;
1668
1669     if (PL_in_eval) {
1670         if (PL_in_eval & EVAL_KEEPERR) {
1671                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1672                                SvPV_nolen_const(err));
1673         }
1674         else
1675             sv_catsv(ERRSV, err);
1676     }
1677     else if (PL_errors)
1678         sv_catsv(PL_errors, err);
1679     else
1680         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1681     if (PL_parser)
1682         ++PL_parser->error_count;
1683 }
1684
1685 void
1686 Perl_die_unwind(pTHX_ SV *msv)
1687 {
1688     dVAR;
1689     SV *exceptsv = sv_mortalcopy(msv);
1690     U8 in_eval = PL_in_eval;
1691     PERL_ARGS_ASSERT_DIE_UNWIND;
1692
1693     if (in_eval) {
1694         I32 cxix;
1695         I32 gimme;
1696
1697         /*
1698          * Historically, perl used to set ERRSV ($@) early in the die
1699          * process and rely on it not getting clobbered during unwinding.
1700          * That sucked, because it was liable to get clobbered, so the
1701          * setting of ERRSV used to emit the exception from eval{} has
1702          * been moved to much later, after unwinding (see just before
1703          * JMPENV_JUMP below).  However, some modules were relying on the
1704          * early setting, by examining $@ during unwinding to use it as
1705          * a flag indicating whether the current unwinding was caused by
1706          * an exception.  It was never a reliable flag for that purpose,
1707          * being totally open to false positives even without actual
1708          * clobberage, but was useful enough for production code to
1709          * semantically rely on it.
1710          *
1711          * We'd like to have a proper introspective interface that
1712          * explicitly describes the reason for whatever unwinding
1713          * operations are currently in progress, so that those modules
1714          * work reliably and $@ isn't further overloaded.  But we don't
1715          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1716          * now *additionally* set here, before unwinding, to serve as the
1717          * (unreliable) flag that it used to.
1718          *
1719          * This behaviour is temporary, and should be removed when a
1720          * proper way to detect exceptional unwinding has been developed.
1721          * As of 2010-12, the authors of modules relying on the hack
1722          * are aware of the issue, because the modules failed on
1723          * perls 5.13.{1..7} which had late setting of $@ without this
1724          * early-setting hack.
1725          */
1726         if (!(in_eval & EVAL_KEEPERR)) {
1727             SvTEMP_off(exceptsv);
1728             sv_setsv(ERRSV, exceptsv);
1729         }
1730
1731         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1732                && PL_curstackinfo->si_prev)
1733         {
1734             dounwind(-1);
1735             POPSTACK;
1736         }
1737
1738         if (cxix >= 0) {
1739             I32 optype;
1740             SV *namesv;
1741             register PERL_CONTEXT *cx;
1742             SV **newsp;
1743             COP *oldcop;
1744             JMPENV *restartjmpenv;
1745             OP *restartop;
1746
1747             if (cxix < cxstack_ix)
1748                 dounwind(cxix);
1749
1750             POPBLOCK(cx,PL_curpm);
1751             if (CxTYPE(cx) != CXt_EVAL) {
1752                 STRLEN msglen;
1753                 const char* message = SvPVx_const(exceptsv, msglen);
1754                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1755                 PerlIO_write(Perl_error_log, message, msglen);
1756                 my_exit(1);
1757             }
1758             POPEVAL(cx);
1759             namesv = cx->blk_eval.old_namesv;
1760             oldcop = cx->blk_oldcop;
1761             restartjmpenv = cx->blk_eval.cur_top_env;
1762             restartop = cx->blk_eval.retop;
1763
1764             if (gimme == G_SCALAR)
1765                 *++newsp = &PL_sv_undef;
1766             PL_stack_sp = newsp;
1767
1768             LEAVE;
1769
1770             /* LEAVE could clobber PL_curcop (see save_re_context())
1771              * XXX it might be better to find a way to avoid messing with
1772              * PL_curcop in save_re_context() instead, but this is a more
1773              * minimal fix --GSAR */
1774             PL_curcop = oldcop;
1775
1776             if (optype == OP_REQUIRE) {
1777                 const char* const msg = SvPVx_nolen_const(exceptsv);
1778                 (void)hv_store(GvHVn(PL_incgv),
1779                                SvPVX_const(namesv), SvCUR(namesv),
1780                                &PL_sv_undef, 0);
1781                 /* note that unlike pp_entereval, pp_require isn't
1782                  * supposed to trap errors. So now that we've popped the
1783                  * EVAL that pp_require pushed, and processed the error
1784                  * message, rethrow the error */
1785                 Perl_croak(aTHX_ "%sCompilation failed in require",
1786                            *msg ? msg : "Unknown error\n");
1787             }
1788             if (in_eval & EVAL_KEEPERR) {
1789                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1790                                SvPV_nolen_const(exceptsv));
1791             }
1792             else {
1793                 sv_setsv(ERRSV, exceptsv);
1794             }
1795             PL_restartjmpenv = restartjmpenv;
1796             PL_restartop = restartop;
1797             JMPENV_JUMP(3);
1798             /* NOTREACHED */
1799         }
1800     }
1801
1802     write_to_stderr(exceptsv);
1803     my_failure_exit();
1804     /* NOTREACHED */
1805 }
1806
1807 PP(pp_xor)
1808 {
1809     dVAR; dSP; dPOPTOPssrl;
1810     if (SvTRUE(left) != SvTRUE(right))
1811         RETSETYES;
1812     else
1813         RETSETNO;
1814 }
1815
1816 /*
1817 =for apidoc caller_cx
1818
1819 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1820 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1821 information returned to Perl by C<caller>. Note that XSUBs don't get a
1822 stack frame, so C<caller_cx(0, NULL)> will return information for the
1823 immediately-surrounding Perl code.
1824
1825 This function skips over the automatic calls to C<&DB::sub> made on the
1826 behalf of the debugger. If the stack frame requested was a sub called by
1827 C<DB::sub>, the return value will be the frame for the call to
1828 C<DB::sub>, since that has the correct line number/etc. for the call
1829 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1830 frame for the sub call itself.
1831
1832 =cut
1833 */
1834
1835 const PERL_CONTEXT *
1836 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1837 {
1838     register I32 cxix = dopoptosub(cxstack_ix);
1839     register const PERL_CONTEXT *cx;
1840     register const PERL_CONTEXT *ccstack = cxstack;
1841     const PERL_SI *top_si = PL_curstackinfo;
1842
1843     for (;;) {
1844         /* we may be in a higher stacklevel, so dig down deeper */
1845         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1846             top_si = top_si->si_prev;
1847             ccstack = top_si->si_cxstack;
1848             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1849         }
1850         if (cxix < 0)
1851             return NULL;
1852         /* caller() should not report the automatic calls to &DB::sub */
1853         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1854                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1855             count++;
1856         if (!count--)
1857             break;
1858         cxix = dopoptosub_at(ccstack, cxix - 1);
1859     }
1860
1861     cx = &ccstack[cxix];
1862     if (dbcxp) *dbcxp = cx;
1863
1864     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1865         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1866         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1867            field below is defined for any cx. */
1868         /* caller() should not report the automatic calls to &DB::sub */
1869         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1870             cx = &ccstack[dbcxix];
1871     }
1872
1873     return cx;
1874 }
1875
1876 PP(pp_caller)
1877 {
1878     dVAR;
1879     dSP;
1880     register const PERL_CONTEXT *cx;
1881     const PERL_CONTEXT *dbcx;
1882     I32 gimme;
1883     const char *stashname;
1884     I32 count = 0;
1885
1886     if (MAXARG)
1887         count = POPi;
1888
1889     cx = caller_cx(count, &dbcx);
1890     if (!cx) {
1891         if (GIMME != G_ARRAY) {
1892             EXTEND(SP, 1);
1893             RETPUSHUNDEF;
1894         }
1895         RETURN;
1896     }
1897
1898     stashname = CopSTASHPV(cx->blk_oldcop);
1899     if (GIMME != G_ARRAY) {
1900         EXTEND(SP, 1);
1901         if (!stashname)
1902             PUSHs(&PL_sv_undef);
1903         else {
1904             dTARGET;
1905             sv_setpv(TARG, stashname);
1906             PUSHs(TARG);
1907         }
1908         RETURN;
1909     }
1910
1911     EXTEND(SP, 11);
1912
1913     if (!stashname)
1914         PUSHs(&PL_sv_undef);
1915     else
1916         mPUSHs(newSVpv(stashname, 0));
1917     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1918     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1919     if (!MAXARG)
1920         RETURN;
1921     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1922         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1923         /* So is ccstack[dbcxix]. */
1924         if (isGV(cvgv)) {
1925             SV * const sv = newSV(0);
1926             gv_efullname3(sv, cvgv, NULL);
1927             mPUSHs(sv);
1928             PUSHs(boolSV(CxHASARGS(cx)));
1929         }
1930         else {
1931             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1932             PUSHs(boolSV(CxHASARGS(cx)));
1933         }
1934     }
1935     else {
1936         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1937         mPUSHi(0);
1938     }
1939     gimme = (I32)cx->blk_gimme;
1940     if (gimme == G_VOID)
1941         PUSHs(&PL_sv_undef);
1942     else
1943         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1944     if (CxTYPE(cx) == CXt_EVAL) {
1945         /* eval STRING */
1946         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1947             PUSHs(cx->blk_eval.cur_text);
1948             PUSHs(&PL_sv_no);
1949         }
1950         /* require */
1951         else if (cx->blk_eval.old_namesv) {
1952             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1953             PUSHs(&PL_sv_yes);
1954         }
1955         /* eval BLOCK (try blocks have old_namesv == 0) */
1956         else {
1957             PUSHs(&PL_sv_undef);
1958             PUSHs(&PL_sv_undef);
1959         }
1960     }
1961     else {
1962         PUSHs(&PL_sv_undef);
1963         PUSHs(&PL_sv_undef);
1964     }
1965     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1966         && CopSTASH_eq(PL_curcop, PL_debstash))
1967     {
1968         AV * const ary = cx->blk_sub.argarray;
1969         const int off = AvARRAY(ary) - AvALLOC(ary);
1970
1971         if (!PL_dbargs)
1972             Perl_init_dbargs(aTHX);
1973
1974         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1975             av_extend(PL_dbargs, AvFILLp(ary) + off);
1976         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1977         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1978     }
1979     /* XXX only hints propagated via op_private are currently
1980      * visible (others are not easily accessible, since they
1981      * use the global PL_hints) */
1982     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1983     {
1984         SV * mask ;
1985         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1986
1987         if  (old_warnings == pWARN_NONE ||
1988                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1989             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1990         else if (old_warnings == pWARN_ALL ||
1991                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1992             /* Get the bit mask for $warnings::Bits{all}, because
1993              * it could have been extended by warnings::register */
1994             SV **bits_all;
1995             HV * const bits = get_hv("warnings::Bits", 0);
1996             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1997                 mask = newSVsv(*bits_all);
1998             }
1999             else {
2000                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2001             }
2002         }
2003         else
2004             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2005         mPUSHs(mask);
2006     }
2007
2008     PUSHs(cx->blk_oldcop->cop_hints_hash ?
2009           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2010           : &PL_sv_undef);
2011     RETURN;
2012 }
2013
2014 PP(pp_reset)
2015 {
2016     dVAR;
2017     dSP;
2018     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
2019     sv_reset(tmps, CopSTASH(PL_curcop));
2020     PUSHs(&PL_sv_yes);
2021     RETURN;
2022 }
2023
2024 /* like pp_nextstate, but used instead when the debugger is active */
2025
2026 PP(pp_dbstate)
2027 {
2028     dVAR;
2029     PL_curcop = (COP*)PL_op;
2030     TAINT_NOT;          /* Each statement is presumed innocent */
2031     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2032     FREETMPS;
2033
2034     PERL_ASYNC_CHECK();
2035
2036     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2037             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2038     {
2039         dSP;
2040         register PERL_CONTEXT *cx;
2041         const I32 gimme = G_ARRAY;
2042         U8 hasargs;
2043         GV * const gv = PL_DBgv;
2044         register CV * const cv = GvCV(gv);
2045
2046         if (!cv)
2047             DIE(aTHX_ "No DB::DB routine defined");
2048
2049         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2050             /* don't do recursive DB::DB call */
2051             return NORMAL;
2052
2053         ENTER;
2054         SAVETMPS;
2055
2056         SAVEI32(PL_debug);
2057         SAVESTACK_POS();
2058         PL_debug = 0;
2059         hasargs = 0;
2060         SPAGAIN;
2061
2062         if (CvISXSUB(cv)) {
2063             CvDEPTH(cv)++;
2064             PUSHMARK(SP);
2065             (void)(*CvXSUB(cv))(aTHX_ cv);
2066             CvDEPTH(cv)--;
2067             FREETMPS;
2068             LEAVE;
2069             return NORMAL;
2070         }
2071         else {
2072             PUSHBLOCK(cx, CXt_SUB, SP);
2073             PUSHSUB_DB(cx);
2074             cx->blk_sub.retop = PL_op->op_next;
2075             CvDEPTH(cv)++;
2076             SAVECOMPPAD();
2077             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2078             RETURNOP(CvSTART(cv));
2079         }
2080     }
2081     else
2082         return NORMAL;
2083 }
2084
2085 PP(pp_enteriter)
2086 {
2087     dVAR; dSP; dMARK;
2088     register PERL_CONTEXT *cx;
2089     const I32 gimme = GIMME_V;
2090     void *itervar; /* location of the iteration variable */
2091     U8 cxtype = CXt_LOOP_FOR;
2092
2093     ENTER_with_name("loop1");
2094     SAVETMPS;
2095
2096     if (PL_op->op_targ) {                        /* "my" variable */
2097         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2098             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2099             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2100                     SVs_PADSTALE, SVs_PADSTALE);
2101         }
2102         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2103 #ifdef USE_ITHREADS
2104         itervar = PL_comppad;
2105 #else
2106         itervar = &PAD_SVl(PL_op->op_targ);
2107 #endif
2108     }
2109     else {                                      /* symbol table variable */
2110         GV * const gv = MUTABLE_GV(POPs);
2111         SV** svp = &GvSV(gv);
2112         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2113         *svp = newSV(0);
2114         itervar = (void *)gv;
2115     }
2116
2117     if (PL_op->op_private & OPpITER_DEF)
2118         cxtype |= CXp_FOR_DEF;
2119
2120     ENTER_with_name("loop2");
2121
2122     PUSHBLOCK(cx, cxtype, SP);
2123     PUSHLOOP_FOR(cx, itervar, MARK);
2124     if (PL_op->op_flags & OPf_STACKED) {
2125         SV *maybe_ary = POPs;
2126         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2127             dPOPss;
2128             SV * const right = maybe_ary;
2129             SvGETMAGIC(sv);
2130             SvGETMAGIC(right);
2131             if (RANGE_IS_NUMERIC(sv,right)) {
2132                 cx->cx_type &= ~CXTYPEMASK;
2133                 cx->cx_type |= CXt_LOOP_LAZYIV;
2134                 /* Make sure that no-one re-orders cop.h and breaks our
2135                    assumptions */
2136                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2137 #ifdef NV_PRESERVES_UV
2138                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2139                                   (SvNV(sv) > (NV)IV_MAX)))
2140                         ||
2141                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2142                                      (SvNV(right) < (NV)IV_MIN))))
2143 #else
2144                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2145                                   ||
2146                                   ((SvNV(sv) > 0) &&
2147                                         ((SvUV(sv) > (UV)IV_MAX) ||
2148                                          (SvNV(sv) > (NV)UV_MAX)))))
2149                         ||
2150                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2151                                      ||
2152                                      ((SvNV(right) > 0) &&
2153                                         ((SvUV(right) > (UV)IV_MAX) ||
2154                                          (SvNV(right) > (NV)UV_MAX))))))
2155 #endif
2156                     DIE(aTHX_ "Range iterator outside integer range");
2157                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2158                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2159 #ifdef DEBUGGING
2160                 /* for correct -Dstv display */
2161                 cx->blk_oldsp = sp - PL_stack_base;
2162 #endif
2163             }
2164             else {
2165                 cx->cx_type &= ~CXTYPEMASK;
2166                 cx->cx_type |= CXt_LOOP_LAZYSV;
2167                 /* Make sure that no-one re-orders cop.h and breaks our
2168                    assumptions */
2169                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2170                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2171                 cx->blk_loop.state_u.lazysv.end = right;
2172                 SvREFCNT_inc(right);
2173                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2174                 /* This will do the upgrade to SVt_PV, and warn if the value
2175                    is uninitialised.  */
2176                 (void) SvPV_nolen_const(right);
2177                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2178                    to replace !SvOK() with a pointer to "".  */
2179                 if (!SvOK(right)) {
2180                     SvREFCNT_dec(right);
2181                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2182                 }
2183             }
2184         }
2185         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2186             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2187             SvREFCNT_inc(maybe_ary);
2188             cx->blk_loop.state_u.ary.ix =
2189                 (PL_op->op_private & OPpITER_REVERSED) ?
2190                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2191                 -1;
2192         }
2193     }
2194     else { /* iterating over items on the stack */
2195         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2196         if (PL_op->op_private & OPpITER_REVERSED) {
2197             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2198         }
2199         else {
2200             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2201         }
2202     }
2203
2204     RETURN;
2205 }
2206
2207 PP(pp_enterloop)
2208 {
2209     dVAR; dSP;
2210     register PERL_CONTEXT *cx;
2211     const I32 gimme = GIMME_V;
2212
2213     ENTER_with_name("loop1");
2214     SAVETMPS;
2215     ENTER_with_name("loop2");
2216
2217     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2218     PUSHLOOP_PLAIN(cx, SP);
2219
2220     RETURN;
2221 }
2222
2223 PP(pp_leaveloop)
2224 {
2225     dVAR; dSP;
2226     register PERL_CONTEXT *cx;
2227     I32 gimme;
2228     SV **newsp;
2229     PMOP *newpm;
2230     SV **mark;
2231
2232     POPBLOCK(cx,newpm);
2233     assert(CxTYPE_is_LOOP(cx));
2234     mark = newsp;
2235     newsp = PL_stack_base + cx->blk_loop.resetsp;
2236
2237     TAINT_NOT;
2238     if (gimme == G_VOID)
2239         NOOP;
2240     else if (gimme == G_SCALAR) {
2241         if (mark < SP)
2242             *++newsp = sv_mortalcopy(*SP);
2243         else
2244             *++newsp = &PL_sv_undef;
2245     }
2246     else {
2247         while (mark < SP) {
2248             *++newsp = sv_mortalcopy(*++mark);
2249             TAINT_NOT;          /* Each item is independent */
2250         }
2251     }
2252     SP = newsp;
2253     PUTBACK;
2254
2255     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2256     PL_curpm = newpm;   /* ... and pop $1 et al */
2257
2258     LEAVE_with_name("loop2");
2259     LEAVE_with_name("loop1");
2260
2261     return NORMAL;
2262 }
2263
2264 PP(pp_return)
2265 {
2266     dVAR; dSP; dMARK;
2267     register PERL_CONTEXT *cx;
2268     bool popsub2 = FALSE;
2269     bool clear_errsv = FALSE;
2270     bool lval = FALSE;
2271     I32 gimme;
2272     SV **newsp;
2273     PMOP *newpm;
2274     I32 optype = 0;
2275     SV *namesv;
2276     SV *sv;
2277     OP *retop = NULL;
2278
2279     const I32 cxix = dopoptosub(cxstack_ix);
2280
2281     if (cxix < 0) {
2282         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2283                                      * sort block, which is a CXt_NULL
2284                                      * not a CXt_SUB */
2285             dounwind(0);
2286             PL_stack_base[1] = *PL_stack_sp;
2287             PL_stack_sp = PL_stack_base + 1;
2288             return 0;
2289         }
2290         else
2291             DIE(aTHX_ "Can't return outside a subroutine");
2292     }
2293     if (cxix < cxstack_ix)
2294         dounwind(cxix);
2295
2296     if (CxMULTICALL(&cxstack[cxix])) {
2297         gimme = cxstack[cxix].blk_gimme;
2298         if (gimme == G_VOID)
2299             PL_stack_sp = PL_stack_base;
2300         else if (gimme == G_SCALAR) {
2301             PL_stack_base[1] = *PL_stack_sp;
2302             PL_stack_sp = PL_stack_base + 1;
2303         }
2304         return 0;
2305     }
2306
2307     POPBLOCK(cx,newpm);
2308     switch (CxTYPE(cx)) {
2309     case CXt_SUB:
2310         popsub2 = TRUE;
2311         lval = !!CvLVALUE(cx->blk_sub.cv);
2312         retop = cx->blk_sub.retop;
2313         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2314         break;
2315     case CXt_EVAL:
2316         if (!(PL_in_eval & EVAL_KEEPERR))
2317             clear_errsv = TRUE;
2318         POPEVAL(cx);
2319         namesv = cx->blk_eval.old_namesv;
2320         retop = cx->blk_eval.retop;
2321         if (CxTRYBLOCK(cx))
2322             break;
2323         if (optype == OP_REQUIRE &&
2324             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2325         {
2326             /* Unassume the success we assumed earlier. */
2327             (void)hv_delete(GvHVn(PL_incgv),
2328                             SvPVX_const(namesv), SvCUR(namesv),
2329                             G_DISCARD);
2330             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2331         }
2332         break;
2333     case CXt_FORMAT:
2334         POPFORMAT(cx);
2335         retop = cx->blk_sub.retop;
2336         break;
2337     default:
2338         DIE(aTHX_ "panic: return");
2339     }
2340
2341     TAINT_NOT;
2342     if (gimme == G_SCALAR) {
2343         if (MARK < SP) {
2344             if (popsub2) {
2345                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2346                     if (SvTEMP(TOPs)) {
2347                         *++newsp = SvREFCNT_inc(*SP);
2348                         FREETMPS;
2349                         sv_2mortal(*newsp);
2350                     }
2351                     else {
2352                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2353                         FREETMPS;
2354                         *++newsp = sv_mortalcopy(sv);
2355                         SvREFCNT_dec(sv);
2356                     }
2357                 }
2358                 else
2359                     *++newsp =
2360                         (lval || SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2361             }
2362             else
2363                 *++newsp = sv_mortalcopy(*SP);
2364         }
2365         else
2366             *++newsp = &PL_sv_undef;
2367     }
2368     else if (gimme == G_ARRAY) {
2369         while (++MARK <= SP) {
2370             *++newsp = popsub2 && (lval || SvTEMP(*MARK))
2371                         ? *MARK : sv_mortalcopy(*MARK);
2372             TAINT_NOT;          /* Each item is independent */
2373         }
2374     }
2375     PL_stack_sp = newsp;
2376
2377     LEAVE;
2378     /* Stack values are safe: */
2379     if (popsub2) {
2380         cxstack_ix--;
2381         POPSUB(cx,sv);  /* release CV and @_ ... */
2382     }
2383     else
2384         sv = NULL;
2385     PL_curpm = newpm;   /* ... and pop $1 et al */
2386
2387     LEAVESUB(sv);
2388     if (clear_errsv) {
2389         CLEAR_ERRSV();
2390     }
2391     return retop;
2392 }
2393
2394 PP(pp_last)
2395 {
2396     dVAR; dSP;
2397     I32 cxix;
2398     register PERL_CONTEXT *cx;
2399     I32 pop2 = 0;
2400     I32 gimme;
2401     I32 optype;
2402     OP *nextop = NULL;
2403     SV **newsp;
2404     PMOP *newpm;
2405     SV **mark;
2406     SV *sv = NULL;
2407
2408
2409     if (PL_op->op_flags & OPf_SPECIAL) {
2410         cxix = dopoptoloop(cxstack_ix);
2411         if (cxix < 0)
2412             DIE(aTHX_ "Can't \"last\" outside a loop block");
2413     }
2414     else {
2415         cxix = dopoptolabel(cPVOP->op_pv);
2416         if (cxix < 0)
2417             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2418     }
2419     if (cxix < cxstack_ix)
2420         dounwind(cxix);
2421
2422     POPBLOCK(cx,newpm);
2423     cxstack_ix++; /* temporarily protect top context */
2424     mark = newsp;
2425     switch (CxTYPE(cx)) {
2426     case CXt_LOOP_LAZYIV:
2427     case CXt_LOOP_LAZYSV:
2428     case CXt_LOOP_FOR:
2429     case CXt_LOOP_PLAIN:
2430         pop2 = CxTYPE(cx);
2431         newsp = PL_stack_base + cx->blk_loop.resetsp;
2432         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2433         break;
2434     case CXt_SUB:
2435         pop2 = CXt_SUB;
2436         nextop = cx->blk_sub.retop;
2437         break;
2438     case CXt_EVAL:
2439         POPEVAL(cx);
2440         nextop = cx->blk_eval.retop;
2441         break;
2442     case CXt_FORMAT:
2443         POPFORMAT(cx);
2444         nextop = cx->blk_sub.retop;
2445         break;
2446     default:
2447         DIE(aTHX_ "panic: last");
2448     }
2449
2450     TAINT_NOT;
2451     if (gimme == G_SCALAR) {
2452         if (MARK < SP)
2453             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2454                         ? *SP : sv_mortalcopy(*SP);
2455         else
2456             *++newsp = &PL_sv_undef;
2457     }
2458     else if (gimme == G_ARRAY) {
2459         while (++MARK <= SP) {
2460             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2461                         ? *MARK : sv_mortalcopy(*MARK);
2462             TAINT_NOT;          /* Each item is independent */
2463         }
2464     }
2465     SP = newsp;
2466     PUTBACK;
2467
2468     LEAVE;
2469     cxstack_ix--;
2470     /* Stack values are safe: */
2471     switch (pop2) {
2472     case CXt_LOOP_LAZYIV:
2473     case CXt_LOOP_PLAIN:
2474     case CXt_LOOP_LAZYSV:
2475     case CXt_LOOP_FOR:
2476         POPLOOP(cx);    /* release loop vars ... */
2477         LEAVE;
2478         break;
2479     case CXt_SUB:
2480         POPSUB(cx,sv);  /* release CV and @_ ... */
2481         break;
2482     }
2483     PL_curpm = newpm;   /* ... and pop $1 et al */
2484
2485     LEAVESUB(sv);
2486     PERL_UNUSED_VAR(optype);
2487     PERL_UNUSED_VAR(gimme);
2488     return nextop;
2489 }
2490
2491 PP(pp_next)
2492 {
2493     dVAR;
2494     I32 cxix;
2495     register PERL_CONTEXT *cx;
2496     I32 inner;
2497
2498     if (PL_op->op_flags & OPf_SPECIAL) {
2499         cxix = dopoptoloop(cxstack_ix);
2500         if (cxix < 0)
2501             DIE(aTHX_ "Can't \"next\" outside a loop block");
2502     }
2503     else {
2504         cxix = dopoptolabel(cPVOP->op_pv);
2505         if (cxix < 0)
2506             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2507     }
2508     if (cxix < cxstack_ix)
2509         dounwind(cxix);
2510
2511     /* clear off anything above the scope we're re-entering, but
2512      * save the rest until after a possible continue block */
2513     inner = PL_scopestack_ix;
2514     TOPBLOCK(cx);
2515     if (PL_scopestack_ix < inner)
2516         leave_scope(PL_scopestack[PL_scopestack_ix]);
2517     PL_curcop = cx->blk_oldcop;
2518     return (cx)->blk_loop.my_op->op_nextop;
2519 }
2520
2521 PP(pp_redo)
2522 {
2523     dVAR;
2524     I32 cxix;
2525     register PERL_CONTEXT *cx;
2526     I32 oldsave;
2527     OP* redo_op;
2528
2529     if (PL_op->op_flags & OPf_SPECIAL) {
2530         cxix = dopoptoloop(cxstack_ix);
2531         if (cxix < 0)
2532             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2533     }
2534     else {
2535         cxix = dopoptolabel(cPVOP->op_pv);
2536         if (cxix < 0)
2537             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2538     }
2539     if (cxix < cxstack_ix)
2540         dounwind(cxix);
2541
2542     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2543     if (redo_op->op_type == OP_ENTER) {
2544         /* pop one less context to avoid $x being freed in while (my $x..) */
2545         cxstack_ix++;
2546         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2547         redo_op = redo_op->op_next;
2548     }
2549
2550     TOPBLOCK(cx);
2551     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2552     LEAVE_SCOPE(oldsave);
2553     FREETMPS;
2554     PL_curcop = cx->blk_oldcop;
2555     return redo_op;
2556 }
2557
2558 STATIC OP *
2559 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2560 {
2561     dVAR;
2562     OP **ops = opstack;
2563     static const char too_deep[] = "Target of goto is too deeply nested";
2564
2565     PERL_ARGS_ASSERT_DOFINDLABEL;
2566
2567     if (ops >= oplimit)
2568         Perl_croak(aTHX_ too_deep);
2569     if (o->op_type == OP_LEAVE ||
2570         o->op_type == OP_SCOPE ||
2571         o->op_type == OP_LEAVELOOP ||
2572         o->op_type == OP_LEAVESUB ||
2573         o->op_type == OP_LEAVETRY)
2574     {
2575         *ops++ = cUNOPo->op_first;
2576         if (ops >= oplimit)
2577             Perl_croak(aTHX_ too_deep);
2578     }
2579     *ops = 0;
2580     if (o->op_flags & OPf_KIDS) {
2581         OP *kid;
2582         /* First try all the kids at this level, since that's likeliest. */
2583         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2584             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2585                 const char *kid_label = CopLABEL(kCOP);
2586                 if (kid_label && strEQ(kid_label, label))
2587                     return kid;
2588             }
2589         }
2590         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2591             if (kid == PL_lastgotoprobe)
2592                 continue;
2593             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2594                 if (ops == opstack)
2595                     *ops++ = kid;
2596                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2597                          ops[-1]->op_type == OP_DBSTATE)
2598                     ops[-1] = kid;
2599                 else
2600                     *ops++ = kid;
2601             }
2602             if ((o = dofindlabel(kid, label, ops, oplimit)))
2603                 return o;
2604         }
2605     }
2606     *ops = 0;
2607     return 0;
2608 }
2609
2610 PP(pp_goto)
2611 {
2612     dVAR; dSP;
2613     OP *retop = NULL;
2614     I32 ix;
2615     register PERL_CONTEXT *cx;
2616 #define GOTO_DEPTH 64
2617     OP *enterops[GOTO_DEPTH];
2618     const char *label = NULL;
2619     const bool do_dump = (PL_op->op_type == OP_DUMP);
2620     static const char must_have_label[] = "goto must have label";
2621
2622     if (PL_op->op_flags & OPf_STACKED) {
2623         SV * const sv = POPs;
2624
2625         /* This egregious kludge implements goto &subroutine */
2626         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2627             I32 cxix;
2628             register PERL_CONTEXT *cx;
2629             CV *cv = MUTABLE_CV(SvRV(sv));
2630             SV** mark;
2631             I32 items = 0;
2632             I32 oldsave;
2633             bool reified = 0;
2634
2635         retry:
2636             if (!CvROOT(cv) && !CvXSUB(cv)) {
2637                 const GV * const gv = CvGV(cv);
2638                 if (gv) {
2639                     GV *autogv;
2640                     SV *tmpstr;
2641                     /* autoloaded stub? */
2642                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2643                         goto retry;
2644                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2645                                           GvNAMELEN(gv), FALSE);
2646                     if (autogv && (cv = GvCV(autogv)))
2647                         goto retry;
2648                     tmpstr = sv_newmortal();
2649                     gv_efullname3(tmpstr, gv, NULL);
2650                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2651                 }
2652                 DIE(aTHX_ "Goto undefined subroutine");
2653             }
2654
2655             /* First do some returnish stuff. */
2656             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2657             FREETMPS;
2658             cxix = dopoptosub(cxstack_ix);
2659             if (cxix < 0)
2660                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2661             if (cxix < cxstack_ix)
2662                 dounwind(cxix);
2663             TOPBLOCK(cx);
2664             SPAGAIN;
2665             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2666             if (CxTYPE(cx) == CXt_EVAL) {
2667                 if (CxREALEVAL(cx))
2668                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2669                 else
2670                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2671             }
2672             else if (CxMULTICALL(cx))
2673                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2674             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2675                 /* put @_ back onto stack */
2676                 AV* av = cx->blk_sub.argarray;
2677
2678                 items = AvFILLp(av) + 1;
2679                 EXTEND(SP, items+1); /* @_ could have been extended. */
2680                 Copy(AvARRAY(av), SP + 1, items, SV*);
2681                 SvREFCNT_dec(GvAV(PL_defgv));
2682                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2683                 CLEAR_ARGARRAY(av);
2684                 /* abandon @_ if it got reified */
2685                 if (AvREAL(av)) {
2686                     reified = 1;
2687                     SvREFCNT_dec(av);
2688                     av = newAV();
2689                     av_extend(av, items-1);
2690                     AvREIFY_only(av);
2691                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2692                 }
2693             }
2694             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2695                 AV* const av = GvAV(PL_defgv);
2696                 items = AvFILLp(av) + 1;
2697                 EXTEND(SP, items+1); /* @_ could have been extended. */
2698                 Copy(AvARRAY(av), SP + 1, items, SV*);
2699             }
2700             mark = SP;
2701             SP += items;
2702             if (CxTYPE(cx) == CXt_SUB &&
2703                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2704                 SvREFCNT_dec(cx->blk_sub.cv);
2705             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2706             LEAVE_SCOPE(oldsave);
2707
2708             /* Now do some callish stuff. */
2709             SAVETMPS;
2710             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2711             if (CvISXSUB(cv)) {
2712                 OP* const retop = cx->blk_sub.retop;
2713                 SV **newsp __attribute__unused__;
2714                 I32 gimme __attribute__unused__;
2715                 if (reified) {
2716                     I32 index;
2717                     for (index=0; index<items; index++)
2718                         sv_2mortal(SP[-index]);
2719                 }
2720
2721                 /* XS subs don't have a CxSUB, so pop it */
2722                 POPBLOCK(cx, PL_curpm);
2723                 /* Push a mark for the start of arglist */
2724                 PUSHMARK(mark);
2725                 PUTBACK;
2726                 (void)(*CvXSUB(cv))(aTHX_ cv);
2727                 LEAVE;
2728                 return retop;
2729             }
2730             else {
2731                 AV* const padlist = CvPADLIST(cv);
2732                 if (CxTYPE(cx) == CXt_EVAL) {
2733                     PL_in_eval = CxOLD_IN_EVAL(cx);
2734                     PL_eval_root = cx->blk_eval.old_eval_root;
2735                     cx->cx_type = CXt_SUB;
2736                 }
2737                 cx->blk_sub.cv = cv;
2738                 cx->blk_sub.olddepth = CvDEPTH(cv);
2739
2740                 CvDEPTH(cv)++;
2741                 if (CvDEPTH(cv) < 2)
2742                     SvREFCNT_inc_simple_void_NN(cv);
2743                 else {
2744                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2745                         sub_crush_depth(cv);
2746                     pad_push(padlist, CvDEPTH(cv));
2747                 }
2748                 SAVECOMPPAD();
2749                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2750                 if (CxHASARGS(cx))
2751                 {
2752                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2753
2754                     cx->blk_sub.savearray = GvAV(PL_defgv);
2755                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2756                     CX_CURPAD_SAVE(cx->blk_sub);
2757                     cx->blk_sub.argarray = av;
2758
2759                     if (items >= AvMAX(av) + 1) {
2760                         SV **ary = AvALLOC(av);
2761                         if (AvARRAY(av) != ary) {
2762                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2763                             AvARRAY(av) = ary;
2764                         }
2765                         if (items >= AvMAX(av) + 1) {
2766                             AvMAX(av) = items - 1;
2767                             Renew(ary,items+1,SV*);
2768                             AvALLOC(av) = ary;
2769                             AvARRAY(av) = ary;
2770                         }
2771                     }
2772                     ++mark;
2773                     Copy(mark,AvARRAY(av),items,SV*);
2774                     AvFILLp(av) = items - 1;
2775                     assert(!AvREAL(av));
2776                     if (reified) {
2777                         /* transfer 'ownership' of refcnts to new @_ */
2778                         AvREAL_on(av);
2779                         AvREIFY_off(av);
2780                     }
2781                     while (items--) {
2782                         if (*mark)
2783                             SvTEMP_off(*mark);
2784                         mark++;
2785                     }
2786                 }
2787                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2788                     Perl_get_db_sub(aTHX_ NULL, cv);
2789                     if (PERLDB_GOTO) {
2790                         CV * const gotocv = get_cvs("DB::goto", 0);
2791                         if (gotocv) {
2792                             PUSHMARK( PL_stack_sp );
2793                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2794                             PL_stack_sp--;
2795                         }
2796                     }
2797                 }
2798                 RETURNOP(CvSTART(cv));
2799             }
2800         }
2801         else {
2802             label = SvPV_nolen_const(sv);
2803             if (!(do_dump || *label))
2804                 DIE(aTHX_ must_have_label);
2805         }
2806     }
2807     else if (PL_op->op_flags & OPf_SPECIAL) {
2808         if (! do_dump)
2809             DIE(aTHX_ must_have_label);
2810     }
2811     else
2812         label = cPVOP->op_pv;
2813
2814     PERL_ASYNC_CHECK();
2815
2816     if (label && *label) {
2817         OP *gotoprobe = NULL;
2818         bool leaving_eval = FALSE;
2819         bool in_block = FALSE;
2820         PERL_CONTEXT *last_eval_cx = NULL;
2821
2822         /* find label */
2823
2824         PL_lastgotoprobe = NULL;
2825         *enterops = 0;
2826         for (ix = cxstack_ix; ix >= 0; ix--) {
2827             cx = &cxstack[ix];
2828             switch (CxTYPE(cx)) {
2829             case CXt_EVAL:
2830                 leaving_eval = TRUE;
2831                 if (!CxTRYBLOCK(cx)) {
2832                     gotoprobe = (last_eval_cx ?
2833                                 last_eval_cx->blk_eval.old_eval_root :
2834                                 PL_eval_root);
2835                     last_eval_cx = cx;
2836                     break;
2837                 }
2838                 /* else fall through */
2839             case CXt_LOOP_LAZYIV:
2840             case CXt_LOOP_LAZYSV:
2841             case CXt_LOOP_FOR:
2842             case CXt_LOOP_PLAIN:
2843             case CXt_GIVEN:
2844             case CXt_WHEN:
2845                 gotoprobe = cx->blk_oldcop->op_sibling;
2846                 break;
2847             case CXt_SUBST:
2848                 continue;
2849             case CXt_BLOCK:
2850                 if (ix) {
2851                     gotoprobe = cx->blk_oldcop->op_sibling;
2852                     in_block = TRUE;
2853                 } else
2854                     gotoprobe = PL_main_root;
2855                 break;
2856             case CXt_SUB:
2857                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2858                     gotoprobe = CvROOT(cx->blk_sub.cv);
2859                     break;
2860                 }
2861                 /* FALL THROUGH */
2862             case CXt_FORMAT:
2863             case CXt_NULL:
2864                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2865             default:
2866                 if (ix)
2867                     DIE(aTHX_ "panic: goto");
2868                 gotoprobe = PL_main_root;
2869                 break;
2870             }
2871             if (gotoprobe) {
2872                 retop = dofindlabel(gotoprobe, label,
2873                                     enterops, enterops + GOTO_DEPTH);
2874                 if (retop)
2875                     break;
2876                 if (gotoprobe->op_sibling &&
2877                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
2878                         gotoprobe->op_sibling->op_sibling) {
2879                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
2880                                         label, enterops, enterops + GOTO_DEPTH);
2881                     if (retop)
2882                         break;
2883                 }
2884             }
2885             PL_lastgotoprobe = gotoprobe;
2886         }
2887         if (!retop)
2888             DIE(aTHX_ "Can't find label %s", label);
2889
2890         /* if we're leaving an eval, check before we pop any frames
2891            that we're not going to punt, otherwise the error
2892            won't be caught */
2893
2894         if (leaving_eval && *enterops && enterops[1]) {
2895             I32 i;
2896             for (i = 1; enterops[i]; i++)
2897                 if (enterops[i]->op_type == OP_ENTERITER)
2898                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2899         }
2900
2901         if (*enterops && enterops[1]) {
2902             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2903             if (enterops[i])
2904                 deprecate("\"goto\" to jump into a construct");
2905         }
2906
2907         /* pop unwanted frames */
2908
2909         if (ix < cxstack_ix) {
2910             I32 oldsave;
2911
2912             if (ix < 0)
2913                 ix = 0;
2914             dounwind(ix);
2915             TOPBLOCK(cx);
2916             oldsave = PL_scopestack[PL_scopestack_ix];
2917             LEAVE_SCOPE(oldsave);
2918         }
2919
2920         /* push wanted frames */
2921
2922         if (*enterops && enterops[1]) {
2923             OP * const oldop = PL_op;
2924             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2925             for (; enterops[ix]; ix++) {
2926                 PL_op = enterops[ix];
2927                 /* Eventually we may want to stack the needed arguments
2928                  * for each op.  For now, we punt on the hard ones. */
2929                 if (PL_op->op_type == OP_ENTERITER)
2930                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2931                 PL_op->op_ppaddr(aTHX);
2932             }
2933             PL_op = oldop;
2934         }
2935     }
2936
2937     if (do_dump) {
2938 #ifdef VMS
2939         if (!retop) retop = PL_main_start;
2940 #endif
2941         PL_restartop = retop;
2942         PL_do_undump = TRUE;
2943
2944         my_unexec();
2945
2946         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2947         PL_do_undump = FALSE;
2948     }
2949
2950     RETURNOP(retop);
2951 }
2952
2953 PP(pp_exit)
2954 {
2955     dVAR;
2956     dSP;
2957     I32 anum;
2958
2959     if (MAXARG < 1)
2960         anum = 0;
2961     else {
2962         anum = SvIVx(POPs);
2963 #ifdef VMS
2964         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2965             anum = 0;
2966         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2967 #endif
2968     }
2969     PL_exit_flags |= PERL_EXIT_EXPECTED;
2970 #ifdef PERL_MAD
2971     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2972     if (anum || !(PL_minus_c && PL_madskills))
2973         my_exit(anum);
2974 #else
2975     my_exit(anum);
2976 #endif
2977     PUSHs(&PL_sv_undef);
2978     RETURN;
2979 }
2980
2981 /* Eval. */
2982
2983 STATIC void
2984 S_save_lines(pTHX_ AV *array, SV *sv)
2985 {
2986     const char *s = SvPVX_const(sv);
2987     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2988     I32 line = 1;
2989
2990     PERL_ARGS_ASSERT_SAVE_LINES;
2991
2992     while (s && s < send) {
2993         const char *t;
2994         SV * const tmpstr = newSV_type(SVt_PVMG);
2995
2996         t = (const char *)memchr(s, '\n', send - s);
2997         if (t)
2998             t++;
2999         else
3000             t = send;
3001
3002         sv_setpvn(tmpstr, s, t - s);
3003         av_store(array, line++, tmpstr);
3004         s = t;
3005     }
3006 }
3007
3008 /*
3009 =for apidoc docatch
3010
3011 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3012
3013 0 is used as continue inside eval,
3014
3015 3 is used for a die caught by an inner eval - continue inner loop
3016
3017 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3018 establish a local jmpenv to handle exception traps.
3019
3020 =cut
3021 */
3022 STATIC OP *
3023 S_docatch(pTHX_ OP *o)
3024 {
3025     dVAR;
3026     int ret;
3027     OP * const oldop = PL_op;
3028     dJMPENV;
3029
3030 #ifdef DEBUGGING
3031     assert(CATCH_GET == TRUE);
3032 #endif
3033     PL_op = o;
3034
3035     JMPENV_PUSH(ret);
3036     switch (ret) {
3037     case 0:
3038         assert(cxstack_ix >= 0);
3039         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3040         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3041  redo_body:
3042         CALLRUNOPS(aTHX);
3043         break;
3044     case 3:
3045         /* die caught by an inner eval - continue inner loop */
3046         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3047             PL_restartjmpenv = NULL;
3048             PL_op = PL_restartop;
3049             PL_restartop = 0;
3050             goto redo_body;
3051         }
3052         /* FALL THROUGH */
3053     default:
3054         JMPENV_POP;
3055         PL_op = oldop;
3056         JMPENV_JUMP(ret);
3057         /* NOTREACHED */
3058     }
3059     JMPENV_POP;
3060     PL_op = oldop;
3061     return NULL;
3062 }
3063
3064 /* James Bond: Do you expect me to talk?
3065    Auric Goldfinger: No, Mr. Bond. I expect you to die.
3066
3067    This code is an ugly hack, doesn't work with lexicals in subroutines that are
3068    called more than once, and is only used by regcomp.c, for (?{}) blocks.
3069
3070    Currently it is not used outside the core code. Best if it stays that way.
3071
3072    Hence it's now deprecated, and will be removed.
3073 */
3074 OP *
3075 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3076 /* sv Text to convert to OP tree. */
3077 /* startop op_free() this to undo. */
3078 /* code Short string id of the caller. */
3079 {
3080     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3081     return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3082 }
3083
3084 /* Don't use this. It will go away without warning once the regexp engine is
3085    refactored not to use it.  */
3086 OP *
3087 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3088                               PAD **padp)
3089 {
3090     dVAR; dSP;                          /* Make POPBLOCK work. */
3091     PERL_CONTEXT *cx;
3092     SV **newsp;
3093     I32 gimme = G_VOID;
3094     I32 optype;
3095     OP dummy;
3096     char tbuf[TYPE_DIGITS(long) + 12 + 10];
3097     char *tmpbuf = tbuf;
3098     char *safestr;
3099     int runtime;
3100     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3101     STRLEN len;
3102     bool need_catch;
3103
3104     PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3105
3106     ENTER_with_name("eval");
3107     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3108     SAVETMPS;
3109     /* switch to eval mode */
3110
3111     if (IN_PERL_COMPILETIME) {
3112         SAVECOPSTASH_FREE(&PL_compiling);
3113         CopSTASH_set(&PL_compiling, PL_curstash);
3114     }
3115     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3116         SV * const sv = sv_newmortal();
3117         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3118                        code, (unsigned long)++PL_evalseq,
3119                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3120         tmpbuf = SvPVX(sv);
3121         len = SvCUR(sv);
3122     }
3123     else
3124         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3125                           (unsigned long)++PL_evalseq);
3126     SAVECOPFILE_FREE(&PL_compiling);
3127     CopFILE_set(&PL_compiling, tmpbuf+2);
3128     SAVECOPLINE(&PL_compiling);
3129     CopLINE_set(&PL_compiling, 1);
3130     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3131        deleting the eval's FILEGV from the stash before gv_check() runs
3132        (i.e. before run-time proper). To work around the coredump that
3133        ensues, we always turn GvMULTI_on for any globals that were
3134        introduced within evals. See force_ident(). GSAR 96-10-12 */
3135     safestr = savepvn(tmpbuf, len);
3136     SAVEDELETE(PL_defstash, safestr, len);
3137     SAVEHINTS();
3138 #ifdef OP_IN_REGISTER
3139     PL_opsave = op;
3140 #else
3141     SAVEVPTR(PL_op);
3142 #endif
3143
3144     /* we get here either during compilation, or via pp_regcomp at runtime */
3145     runtime = IN_PERL_RUNTIME;
3146     if (runtime)
3147     {
3148         runcv = find_runcv(NULL);
3149
3150         /* At run time, we have to fetch the hints from PL_curcop. */
3151         PL_hints = PL_curcop->cop_hints;
3152         if (PL_hints & HINT_LOCALIZE_HH) {
3153             /* SAVEHINTS created a new HV in PL_hintgv, which we
3154                need to GC */
3155             SvREFCNT_dec(GvHV(PL_hintgv));
3156             GvHV(PL_hintgv) =
3157              refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3158             hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3159         }
3160         SAVECOMPILEWARNINGS();
3161         PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3162         cophh_free(CopHINTHASH_get(&PL_compiling));
3163         /* XXX Does this need to avoid copying a label? */
3164         PL_compiling.cop_hints_hash
3165          = cophh_copy(PL_curcop->cop_hints_hash);
3166     }
3167
3168     PL_op = &dummy;
3169     PL_op->op_type = OP_ENTEREVAL;
3170     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3171     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3172     PUSHEVAL(cx, 0);
3173     need_catch = CATCH_GET;
3174     CATCH_SET(TRUE);
3175
3176     if (runtime)
3177         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3178     else
3179         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3180     CATCH_SET(need_catch);
3181     POPBLOCK(cx,PL_curpm);
3182     POPEVAL(cx);
3183
3184     (*startop)->op_type = OP_NULL;
3185     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3186     /* XXX DAPM do this properly one year */
3187     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3188     LEAVE_with_name("eval");
3189     if (IN_PERL_COMPILETIME)
3190         CopHINTS_set(&PL_compiling, PL_hints);
3191 #ifdef OP_IN_REGISTER
3192     op = PL_opsave;
3193 #endif
3194     PERL_UNUSED_VAR(newsp);
3195     PERL_UNUSED_VAR(optype);
3196
3197     return PL_eval_start;
3198 }
3199
3200
3201 /*
3202 =for apidoc find_runcv
3203
3204 Locate the CV corresponding to the currently executing sub or eval.
3205 If db_seqp is non_null, skip CVs that are in the DB package and populate
3206 *db_seqp with the cop sequence number at the point that the DB:: code was
3207 entered. (allows debuggers to eval in the scope of the breakpoint rather
3208 than in the scope of the debugger itself).
3209
3210 =cut
3211 */
3212
3213 CV*
3214 Perl_find_runcv(pTHX_ U32 *db_seqp)
3215 {
3216     dVAR;
3217     PERL_SI      *si;
3218
3219     if (db_seqp)
3220         *db_seqp = PL_curcop->cop_seq;
3221     for (si = PL_curstackinfo; si; si = si->si_prev) {
3222         I32 ix;
3223         for (ix = si->si_cxix; ix >= 0; ix--) {
3224             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3225             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3226                 CV * const cv = cx->blk_sub.cv;
3227                 /* skip DB:: code */
3228                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3229                     *db_seqp = cx->blk_oldcop->cop_seq;
3230                     continue;
3231                 }
3232                 return cv;
3233             }
3234             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3235                 return PL_compcv;
3236         }
3237     }
3238     return PL_main_cv;
3239 }
3240
3241
3242 /* Run yyparse() in a setjmp wrapper. Returns:
3243  *   0: yyparse() successful
3244  *   1: yyparse() failed
3245  *   3: yyparse() died
3246  */
3247 STATIC int
3248 S_try_yyparse(pTHX_ int gramtype)
3249 {
3250     int ret;
3251     dJMPENV;
3252
3253     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3254     JMPENV_PUSH(ret);
3255     switch (ret) {
3256     case 0:
3257         ret = yyparse(gramtype) ? 1 : 0;
3258         break;
3259     case 3:
3260         break;
3261     default:
3262         JMPENV_POP;
3263         JMPENV_JUMP(ret);
3264         /* NOTREACHED */
3265     }
3266     JMPENV_POP;
3267     return ret;
3268 }
3269
3270
3271 /* Compile a require/do, an eval '', or a /(?{...})/.
3272  * In the last case, startop is non-null, and contains the address of
3273  * a pointer that should be set to the just-compiled code.
3274  * outside is the lexically enclosing CV (if any) that invoked us.
3275  * Returns a bool indicating whether the compile was successful; if so,
3276  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3277  * pushes undef (also croaks if startop != NULL).
3278  */
3279
3280 STATIC bool
3281 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3282 {
3283     dVAR; dSP;
3284     OP * const saveop = PL_op;
3285     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3286     int yystatus;
3287
3288     PL_in_eval = (in_require
3289                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3290                   : EVAL_INEVAL);
3291
3292     PUSHMARK(SP);
3293
3294     SAVESPTR(PL_compcv);
3295     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3296     CvEVAL_on(PL_compcv);
3297     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3298     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3299
3300     CvOUTSIDE_SEQ(PL_compcv) = seq;
3301     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3302
3303     /* set up a scratch pad */
3304
3305     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3306     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3307
3308
3309     if (!PL_madskills)
3310         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3311
3312     /* make sure we compile in the right package */
3313
3314     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3315         SAVESPTR(PL_curstash);
3316         PL_curstash = CopSTASH(PL_curcop);
3317     }
3318     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3319     SAVESPTR(PL_beginav);
3320     PL_beginav = newAV();
3321     SAVEFREESV(PL_beginav);
3322     SAVESPTR(PL_unitcheckav);
3323     PL_unitcheckav = newAV();
3324     SAVEFREESV(PL_unitcheckav);
3325
3326 #ifdef PERL_MAD
3327     SAVEBOOL(PL_madskills);
3328     PL_madskills = 0;
3329 #endif
3330
3331     /* try to compile it */
3332
3333     PL_eval_root = NULL;
3334     PL_curcop = &PL_compiling;
3335     CopARYBASE_set(PL_curcop, 0);
3336     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3337         PL_in_eval |= EVAL_KEEPERR;
3338     else
3339         CLEAR_ERRSV();
3340
3341     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3342
3343     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3344      * so honour CATCH_GET and trap it here if necessary */
3345
3346     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3347
3348     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3349         SV **newsp;                     /* Used by POPBLOCK. */
3350         PERL_CONTEXT *cx = NULL;
3351         I32 optype;                     /* Used by POPEVAL. */
3352         SV *namesv = NULL;
3353         const char *msg;
3354
3355         PERL_UNUSED_VAR(newsp);
3356         PERL_UNUSED_VAR(optype);
3357
3358         /* note that if yystatus == 3, then the EVAL CX block has already
3359          * been popped, and various vars restored */
3360         PL_op = saveop;
3361         if (yystatus != 3) {
3362             if (PL_eval_root) {
3363                 op_free(PL_eval_root);
3364                 PL_eval_root = NULL;
3365             }
3366             SP = PL_stack_base + POPMARK;       /* pop original mark */
3367             if (!startop) {
3368                 POPBLOCK(cx,PL_curpm);
3369                 POPEVAL(cx);
3370                 namesv = cx->blk_eval.old_namesv;
3371             }
3372         }
3373         if (yystatus != 3)
3374             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3375
3376         msg = SvPVx_nolen_const(ERRSV);
3377         if (in_require) {
3378             if (!cx) {
3379                 /* If cx is still NULL, it means that we didn't go in the
3380                  * POPEVAL branch. */
3381                 cx = &cxstack[cxstack_ix];
3382                 assert(CxTYPE(cx) == CXt_EVAL);
3383                 namesv = cx->blk_eval.old_namesv;
3384             }
3385             (void)hv_store(GvHVn(PL_incgv),
3386                            SvPVX_const(namesv), SvCUR(namesv),
3387                            &PL_sv_undef, 0);
3388             Perl_croak(aTHX_ "%sCompilation failed in require",
3389                        *msg ? msg : "Unknown error\n");
3390         }
3391         else if (startop) {
3392             if (yystatus != 3) {
3393                 POPBLOCK(cx,PL_curpm);
3394                 POPEVAL(cx);
3395             }
3396             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3397                        (*msg ? msg : "Unknown error\n"));
3398         }
3399         else {
3400             if (!*msg) {
3401                 sv_setpvs(ERRSV, "Compilation error");
3402             }
3403         }
3404         PUSHs(&PL_sv_undef);
3405         PUTBACK;
3406         return FALSE;
3407     }
3408     CopLINE_set(&PL_compiling, 0);
3409     if (startop) {
3410         *startop = PL_eval_root;
3411     } else
3412         SAVEFREEOP(PL_eval_root);
3413
3414     /* Set the context for this new optree.
3415      * Propagate the context from the eval(). */
3416     if ((gimme & G_WANT) == G_VOID)
3417         scalarvoid(PL_eval_root);
3418     else if ((gimme & G_WANT) == G_ARRAY)
3419         list(PL_eval_root);
3420     else
3421         scalar(PL_eval_root);
3422
3423     DEBUG_x(dump_eval());
3424
3425     /* Register with debugger: */
3426     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3427         CV * const cv = get_cvs("DB::postponed", 0);
3428         if (cv) {
3429             dSP;
3430             PUSHMARK(SP);
3431             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3432             PUTBACK;
3433             call_sv(MUTABLE_SV(cv), G_DISCARD);
3434         }
3435     }
3436
3437     if (PL_unitcheckav) {
3438         OP *es = PL_eval_start;
3439         call_list(PL_scopestack_ix, PL_unitcheckav);
3440         PL_eval_start = es;
3441     }
3442
3443     /* compiled okay, so do it */
3444
3445     CvDEPTH(PL_compcv) = 1;
3446     SP = PL_stack_base + POPMARK;               /* pop original mark */
3447     PL_op = saveop;                     /* The caller may need it. */
3448     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3449
3450     PUTBACK;
3451     return TRUE;
3452 }
3453
3454 STATIC PerlIO *
3455 S_check_type_and_open(pTHX_ SV *name)
3456 {
3457     Stat_t st;
3458     const char *p = SvPV_nolen_const(name);
3459     const int st_rc = PerlLIO_stat(p, &st);
3460
3461     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3462
3463     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3464         return NULL;
3465     }
3466
3467 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3468     return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3469 #else
3470     return PerlIO_open(p, PERL_SCRIPT_MODE);
3471 #endif
3472 }
3473
3474 #ifndef PERL_DISABLE_PMC
3475 STATIC PerlIO *
3476 S_doopen_pm(pTHX_ SV *name)
3477 {
3478     STRLEN namelen;
3479     const char *p = SvPV_const(name, namelen);
3480
3481     PERL_ARGS_ASSERT_DOOPEN_PM;
3482
3483     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3484         SV *const pmcsv = sv_newmortal();
3485         Stat_t pmcstat;
3486
3487         SvSetSV_nosteal(pmcsv,name);
3488         sv_catpvn(pmcsv, "c", 1);
3489
3490         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3491             return check_type_and_open(pmcsv);
3492     }
3493     return check_type_and_open(name);
3494 }
3495 #else
3496 #  define doopen_pm(name) check_type_and_open(name)
3497 #endif /* !PERL_DISABLE_PMC */
3498
3499 PP(pp_require)
3500 {
3501     dVAR; dSP;
3502     register PERL_CONTEXT *cx;
3503     SV *sv;
3504     const char *name;
3505     STRLEN len;
3506     char * unixname;
3507     STRLEN unixlen;
3508 #ifdef VMS
3509     int vms_unixname = 0;
3510 #endif
3511     const char *tryname = NULL;
3512     SV *namesv = NULL;
3513     const I32 gimme = GIMME_V;
3514     int filter_has_file = 0;
3515     PerlIO *tryrsfp = NULL;
3516     SV *filter_cache = NULL;
3517     SV *filter_state = NULL;
3518     SV *filter_sub = NULL;
3519     SV *hook_sv = NULL;
3520     SV *encoding;
3521     OP *op;
3522
3523     sv = POPs;
3524     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3525         sv = sv_2mortal(new_version(sv));
3526         if (!sv_derived_from(PL_patchlevel, "version"))
3527             upg_version(PL_patchlevel, TRUE);
3528         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3529             if ( vcmp(sv,PL_patchlevel) <= 0 )
3530                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3531                     SVfARG(sv_2mortal(vnormal(sv))),
3532                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3533                 );
3534         }
3535         else {
3536             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3537                 I32 first = 0;
3538                 AV *lav;
3539                 SV * const req = SvRV(sv);
3540                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3541
3542                 /* get the left hand term */
3543                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3544
3545                 first  = SvIV(*av_fetch(lav,0,0));
3546                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3547                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3548                     || av_len(lav) > 1               /* FP with > 3 digits */
3549                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3550                    ) {
3551                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3552                         "%"SVf", stopped",
3553                         SVfARG(sv_2mortal(vnormal(req))),
3554                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3555                     );
3556                 }
3557                 else { /* probably 'use 5.10' or 'use 5.8' */
3558                     SV *hintsv;
3559                     I32 second = 0;
3560
3561                     if (av_len(lav)>=1)
3562                         second = SvIV(*av_fetch(lav,1,0));
3563
3564                     second /= second >= 600  ? 100 : 10;
3565                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3566                                            (int)first, (int)second);
3567                     upg_version(hintsv, TRUE);
3568
3569                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3570                         "--this is only %"SVf", stopped",
3571                         SVfARG(sv_2mortal(vnormal(req))),
3572                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3573                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3574                     );
3575                 }
3576             }
3577         }
3578
3579         RETPUSHYES;
3580     }
3581     name = SvPV_const(sv, len);
3582     if (!(name && len > 0 && *name))
3583         DIE(aTHX_ "Null filename used");
3584     TAINT_PROPER("require");
3585
3586
3587 #ifdef VMS
3588     /* The key in the %ENV hash is in the syntax of file passed as the argument
3589      * usually this is in UNIX format, but sometimes in VMS format, which
3590      * can result in a module being pulled in more than once.
3591      * To prevent this, the key must be stored in UNIX format if the VMS
3592      * name can be translated to UNIX.
3593      */
3594     if ((unixname = tounixspec(name, NULL)) != NULL) {
3595         unixlen = strlen(unixname);
3596         vms_unixname = 1;
3597     }
3598     else
3599 #endif
3600     {
3601         /* if not VMS or VMS name can not be translated to UNIX, pass it
3602          * through.
3603          */
3604         unixname = (char *) name;
3605         unixlen = len;
3606     }
3607     if (PL_op->op_type == OP_REQUIRE) {
3608         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3609                                           unixname, unixlen, 0);
3610         if ( svp ) {
3611             if (*svp != &PL_sv_undef)
3612                 RETPUSHYES;
3613             else
3614                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3615                             "Compilation failed in require", unixname);
3616         }
3617     }
3618
3619     /* prepare to compile file */
3620
3621     if (path_is_absolute(name)) {
3622         /* At this point, name is SvPVX(sv)  */
3623         tryname = name;
3624         tryrsfp = doopen_pm(sv);
3625     }
3626     if (!tryrsfp) {
3627         AV * const ar = GvAVn(PL_incgv);
3628         I32 i;
3629 #ifdef VMS
3630         if (vms_unixname)
3631 #endif
3632         {
3633             namesv = newSV_type(SVt_PV);
3634             for (i = 0; i <= AvFILL(ar); i++) {
3635                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3636
3637                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3638                     mg_get(dirsv);
3639                 if (SvROK(dirsv)) {
3640                     int count;
3641                     SV **svp;
3642                     SV *loader = dirsv;
3643
3644                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3645                         && !sv_isobject(loader))
3646                     {
3647                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3648                     }
3649
3650                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3651                                    PTR2UV(SvRV(dirsv)), name);
3652                     tryname = SvPVX_const(namesv);
3653                     tryrsfp = NULL;
3654
3655                     ENTER_with_name("call_INC");
3656                     SAVETMPS;
3657                     EXTEND(SP, 2);
3658
3659                     PUSHMARK(SP);
3660                     PUSHs(dirsv);
3661                     PUSHs(sv);
3662                     PUTBACK;
3663                     if (sv_isobject(loader))
3664                         count = call_method("INC", G_ARRAY);
3665                     else
3666                         count = call_sv(loader, G_ARRAY);
3667                     SPAGAIN;
3668
3669                     if (count > 0) {
3670                         int i = 0;
3671                         SV *arg;
3672
3673                         SP -= count - 1;
3674                         arg = SP[i++];
3675
3676                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3677                             && !isGV_with_GP(SvRV(arg))) {
3678                             filter_cache = SvRV(arg);
3679                             SvREFCNT_inc_simple_void_NN(filter_cache);
3680
3681                             if (i < count) {
3682                                 arg = SP[i++];
3683                             }
3684                         }
3685
3686                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3687                             arg = SvRV(arg);
3688                         }
3689
3690                         if (isGV_with_GP(arg)) {
3691                             IO * const io = GvIO((const GV *)arg);
3692
3693                             ++filter_has_file;
3694
3695                             if (io) {
3696                                 tryrsfp = IoIFP(io);
3697                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3698                                     PerlIO_close(IoOFP(io));
3699                                 }
3700                                 IoIFP(io) = NULL;
3701                                 IoOFP(io) = NULL;
3702                             }
3703
3704                             if (i < count) {
3705                                 arg = SP[i++];
3706                             }
3707                         }
3708
3709                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3710                             filter_sub = arg;
3711                             SvREFCNT_inc_simple_void_NN(filter_sub);
3712
3713                             if (i < count) {
3714                                 filter_state = SP[i];
3715                                 SvREFCNT_inc_simple_void(filter_state);
3716                             }
3717                         }
3718
3719                         if (!tryrsfp && (filter_cache || filter_sub)) {
3720                             tryrsfp = PerlIO_open(BIT_BUCKET,
3721                                                   PERL_SCRIPT_MODE);
3722                         }
3723                         SP--;
3724                     }
3725
3726                     PUTBACK;
3727                     FREETMPS;
3728                     LEAVE_with_name("call_INC");
3729
3730                     /* Adjust file name if the hook has set an %INC entry.
3731                        This needs to happen after the FREETMPS above.  */
3732                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3733                     if (svp)
3734                         tryname = SvPV_nolen_const(*svp);
3735
3736                     if (tryrsfp) {
3737                         hook_sv = dirsv;
3738                         break;
3739                     }
3740
3741                     filter_has_file = 0;
3742                     if (filter_cache) {
3743                         SvREFCNT_dec(filter_cache);
3744                         filter_cache = NULL;
3745                     }
3746                     if (filter_state) {
3747                         SvREFCNT_dec(filter_state);
3748                         filter_state = NULL;
3749                     }
3750                     if (filter_sub) {
3751                         SvREFCNT_dec(filter_sub);
3752                         filter_sub = NULL;
3753                     }
3754                 }
3755                 else {
3756                   if (!path_is_absolute(name)
3757                   ) {
3758                     const char *dir;
3759                     STRLEN dirlen;
3760
3761                     if (SvOK(dirsv)) {
3762                         dir = SvPV_const(dirsv, dirlen);
3763                     } else {
3764                         dir = "";
3765                         dirlen = 0;
3766                     }
3767
3768 #ifdef VMS
3769                     char *unixdir;
3770                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3771                         continue;
3772                     sv_setpv(namesv, unixdir);
3773                     sv_catpv(namesv, unixname);
3774 #else
3775 #  ifdef __SYMBIAN32__
3776                     if (PL_origfilename[0] &&
3777                         PL_origfilename[1] == ':' &&
3778                         !(dir[0] && dir[1] == ':'))
3779                         Perl_sv_setpvf(aTHX_ namesv,
3780                                        "%c:%s\\%s",
3781                                        PL_origfilename[0],
3782                                        dir, name);
3783                     else
3784                         Perl_sv_setpvf(aTHX_ namesv,
3785                                        "%s\\%s",
3786                                        dir, name);
3787 #  else
3788                     /* The equivalent of
3789                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3790                        but without the need to parse the format string, or
3791                        call strlen on either pointer, and with the correct
3792                        allocation up front.  */
3793                     {
3794                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3795
3796                         memcpy(tmp, dir, dirlen);
3797                         tmp +=dirlen;
3798                         *tmp++ = '/';
3799                         /* name came from an SV, so it will have a '\0' at the
3800                            end that we can copy as part of this memcpy().  */
3801                         memcpy(tmp, name, len + 1);
3802
3803                         SvCUR_set(namesv, dirlen + len + 1);
3804                         SvPOK_on(namesv);
3805                     }
3806 #  endif
3807 #endif
3808                     TAINT_PROPER("require");
3809                     tryname = SvPVX_const(namesv);
3810                     tryrsfp = doopen_pm(namesv);
3811                     if (tryrsfp) {
3812                         if (tryname[0] == '.' && tryname[1] == '/') {
3813                             ++tryname;
3814                             while (*++tryname == '/');
3815                         }
3816                         break;
3817                     }
3818                     else if (errno == EMFILE)
3819                         /* no point in trying other paths if out of handles */
3820                         break;
3821                   }
3822                 }
3823             }
3824         }
3825     }
3826     sv_2mortal(namesv);
3827     if (!tryrsfp) {
3828         if (PL_op->op_type == OP_REQUIRE) {
3829             if(errno == EMFILE) {
3830                 /* diag_listed_as: Can't locate %s */
3831                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3832             } else {
3833                 if (namesv) {                   /* did we lookup @INC? */
3834                     AV * const ar = GvAVn(PL_incgv);
3835                     I32 i;
3836                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3837                     for (i = 0; i <= AvFILL(ar); i++) {
3838                         sv_catpvs(inc, " ");
3839                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3840                     }
3841
3842                     /* diag_listed_as: Can't locate %s */
3843                     DIE(aTHX_
3844                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3845                         name,
3846                         (memEQ(name + len - 2, ".h", 3)
3847                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3848                         (memEQ(name + len - 3, ".ph", 4)
3849                          ? " (did you run h2ph?)" : ""),
3850                         inc
3851                         );
3852                 }
3853             }
3854             DIE(aTHX_ "Can't locate %s", name);
3855         }
3856
3857         RETPUSHUNDEF;
3858     }
3859     else
3860         SETERRNO(0, SS_NORMAL);
3861
3862     /* Assume success here to prevent recursive requirement. */
3863     /* name is never assigned to again, so len is still strlen(name)  */
3864     /* Check whether a hook in @INC has already filled %INC */
3865     if (!hook_sv) {
3866         (void)hv_store(GvHVn(PL_incgv),
3867                        unixname, unixlen, newSVpv(tryname,0),0);
3868     } else {
3869         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3870         if (!svp)
3871             (void)hv_store(GvHVn(PL_incgv),
3872                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3873     }
3874
3875     ENTER_with_name("eval");
3876     SAVETMPS;
3877     SAVECOPFILE_FREE(&PL_compiling);
3878     CopFILE_set(&PL_compiling, tryname);
3879     lex_start(NULL, tryrsfp, 0);
3880
3881     SAVEHINTS();
3882     PL_hints = 0;
3883     hv_clear(GvHV(PL_hintgv));
3884
3885     SAVECOMPILEWARNINGS();
3886     if (PL_dowarn & G_WARN_ALL_ON)
3887         PL_compiling.cop_warnings = pWARN_ALL ;
3888     else if (PL_dowarn & G_WARN_ALL_OFF)
3889         PL_compiling.cop_warnings = pWARN_NONE ;
3890     else
3891         PL_compiling.cop_warnings = pWARN_STD ;
3892
3893     if (filter_sub || filter_cache) {
3894         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3895            than hanging another SV from it. In turn, filter_add() optionally
3896            takes the SV to use as the filter (or creates a new SV if passed
3897            NULL), so simply pass in whatever value filter_cache has.  */
3898         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3899         IoLINES(datasv) = filter_has_file;
3900         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3901         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3902     }
3903
3904     /* switch to eval mode */
3905     PUSHBLOCK(cx, CXt_EVAL, SP);
3906     PUSHEVAL(cx, name);
3907     cx->blk_eval.retop = PL_op->op_next;
3908
3909     SAVECOPLINE(&PL_compiling);
3910     CopLINE_set(&PL_compiling, 0);
3911
3912     PUTBACK;
3913
3914     /* Store and reset encoding. */
3915     encoding = PL_encoding;
3916     PL_encoding = NULL;
3917
3918     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3919         op = DOCATCH(PL_eval_start);
3920     else
3921         op = PL_op->op_next;
3922
3923     /* Restore encoding. */
3924     PL_encoding = encoding;
3925
3926     return op;
3927 }
3928
3929 /* This is a op added to hold the hints hash for
3930    pp_entereval. The hash can be modified by the code
3931    being eval'ed, so we return a copy instead. */
3932
3933 PP(pp_hintseval)
3934 {
3935     dVAR;
3936     dSP;
3937     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3938     RETURN;
3939 }
3940
3941
3942 PP(pp_entereval)
3943 {
3944     dVAR; dSP;
3945     register PERL_CONTEXT *cx;
3946     SV *sv;
3947     const I32 gimme = GIMME_V;
3948     const U32 was = PL_breakable_sub_gen;
3949     char tbuf[TYPE_DIGITS(long) + 12];
3950     bool saved_delete = FALSE;
3951     char *tmpbuf = tbuf;
3952     STRLEN len;
3953     CV* runcv;
3954     U32 seq;
3955     HV *saved_hh = NULL;
3956
3957     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3958         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3959     }
3960     sv = POPs;
3961     if (!SvPOK(sv)) {
3962         /* make sure we've got a plain PV (no overload etc) before testing
3963          * for taint. Making a copy here is probably overkill, but better
3964          * safe than sorry */
3965         STRLEN len;
3966         const char * const p = SvPV_const(sv, len);
3967
3968         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3969     }
3970
3971     TAINT_IF(SvTAINTED(sv));
3972     TAINT_PROPER("eval");
3973
3974     ENTER_with_name("eval");
3975     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3976     SAVETMPS;
3977
3978     /* switch to eval mode */
3979
3980     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3981         SV * const temp_sv = sv_newmortal();
3982         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3983                        (unsigned long)++PL_evalseq,
3984                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3985         tmpbuf = SvPVX(temp_sv);
3986         len = SvCUR(temp_sv);
3987     }
3988     else
3989         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3990     SAVECOPFILE_FREE(&PL_compiling);
3991     CopFILE_set(&PL_compiling, tmpbuf+2);
3992     SAVECOPLINE(&PL_compiling);
3993     CopLINE_set(&PL_compiling, 1);
3994     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3995        deleting the eval's FILEGV from the stash before gv_check() runs
3996        (i.e. before run-time proper). To work around the coredump that
3997        ensues, we always turn GvMULTI_on for any globals that were
3998        introduced within evals. See force_ident(). GSAR 96-10-12 */
3999     SAVEHINTS();
4000     PL_hints = PL_op->op_targ;
4001     if (saved_hh) {
4002         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4003         SvREFCNT_dec(GvHV(PL_hintgv));
4004         GvHV(PL_hintgv) = saved_hh;
4005     }
4006     SAVECOMPILEWARNINGS();
4007     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4008     cophh_free(CopHINTHASH_get(&PL_compiling));
4009     if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
4010         /* The label, if present, is the first entry on the chain. So rather
4011            than writing a blank label in front of it (which involves an
4012            allocation), just use the next entry in the chain.  */
4013         PL_compiling.cop_hints_hash
4014             = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4015         /* Check the assumption that this removed the label.  */
4016         assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4017     }
4018     else
4019         PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4020     /* special case: an eval '' executed within the DB package gets lexically
4021      * placed in the first non-DB CV rather than the current CV - this
4022      * allows the debugger to execute code, find lexicals etc, in the
4023      * scope of the code being debugged. Passing &seq gets find_runcv
4024      * to do the dirty work for us */
4025     runcv = find_runcv(&seq);
4026
4027     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4028     PUSHEVAL(cx, 0);
4029     cx->blk_eval.retop = PL_op->op_next;
4030
4031     /* prepare to compile string */
4032
4033     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4034         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4035     else {
4036         char *const safestr = savepvn(tmpbuf, len);
4037         SAVEDELETE(PL_defstash, safestr, len);
4038         saved_delete = TRUE;
4039     }
4040
4041     PUTBACK;
4042
4043     if (doeval(gimme, NULL, runcv, seq)) {
4044         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4045             ? (PERLDB_LINE || PERLDB_SAVESRC)
4046             :  PERLDB_SAVESRC_NOSUBS) {
4047             /* Retain the filegv we created.  */
4048         } else if (!saved_delete) {
4049             char *const safestr = savepvn(tmpbuf, len);
4050             SAVEDELETE(PL_defstash, safestr, len);
4051         }
4052         return DOCATCH(PL_eval_start);
4053     } else {
4054         /* We have already left the scope set up earlier thanks to the LEAVE
4055            in doeval().  */
4056         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4057             ? (PERLDB_LINE || PERLDB_SAVESRC)
4058             :  PERLDB_SAVESRC_INVALID) {
4059             /* Retain the filegv we created.  */
4060         } else if (!saved_delete) {
4061             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4062         }
4063         return PL_op->op_next;
4064     }
4065 }
4066
4067 PP(pp_leaveeval)
4068 {
4069     dVAR; dSP;
4070     register SV **mark;
4071     SV **newsp;
4072     PMOP *newpm;
4073     I32 gimme;
4074     register PERL_CONTEXT *cx;
4075     OP *retop;
4076     const U8 save_flags = PL_op -> op_flags;
4077     I32 optype;
4078     SV *namesv;
4079
4080     PERL_ASYNC_CHECK();
4081     POPBLOCK(cx,newpm);
4082     POPEVAL(cx);
4083     namesv = cx->blk_eval.old_namesv;
4084     retop = cx->blk_eval.retop;
4085
4086     TAINT_NOT;
4087     if (gimme == G_VOID)
4088         MARK = newsp;
4089     else if (gimme == G_SCALAR) {
4090         MARK = newsp + 1;
4091         if (MARK <= SP) {
4092             if (SvFLAGS(TOPs) & SVs_TEMP)
4093                 *MARK = TOPs;
4094             else
4095                 *MARK = sv_mortalcopy(TOPs);
4096         }
4097         else {
4098             MEXTEND(mark,0);
4099             *MARK = &PL_sv_undef;
4100         }
4101         SP = MARK;
4102     }
4103     else {
4104         /* in case LEAVE wipes old return values */
4105         for (mark = newsp + 1; mark <= SP; mark++) {
4106             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4107                 *mark = sv_mortalcopy(*mark);
4108                 TAINT_NOT;      /* Each item is independent */
4109             }
4110         }
4111     }
4112     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4113
4114 #ifdef DEBUGGING
4115     assert(CvDEPTH(PL_compcv) == 1);
4116 #endif
4117     CvDEPTH(PL_compcv) = 0;
4118
4119     if (optype == OP_REQUIRE &&
4120         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4121     {
4122         /* Unassume the success we assumed earlier. */
4123         (void)hv_delete(GvHVn(PL_incgv),
4124                         SvPVX_const(namesv), SvCUR(namesv),
4125                         G_DISCARD);
4126         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4127                                SVfARG(namesv));
4128         /* die_unwind() did LEAVE, or we won't be here */
4129     }
4130     else {
4131         LEAVE_with_name("eval");
4132         if (!(save_flags & OPf_SPECIAL)) {
4133             CLEAR_ERRSV();
4134         }
4135     }
4136
4137     RETURNOP(retop);
4138 }
4139
4140 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4141    close to the related Perl_create_eval_scope.  */
4142 void
4143 Perl_delete_eval_scope(pTHX)
4144 {
4145     SV **newsp;
4146     PMOP *newpm;
4147     I32 gimme;
4148     register PERL_CONTEXT *cx;
4149     I32 optype;
4150
4151     POPBLOCK(cx,newpm);
4152     POPEVAL(cx);
4153     PL_curpm = newpm;
4154     LEAVE_with_name("eval_scope");
4155     PERL_UNUSED_VAR(newsp);
4156     PERL_UNUSED_VAR(gimme);
4157     PERL_UNUSED_VAR(optype);
4158 }
4159
4160 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4161    also needed by Perl_fold_constants.  */
4162 PERL_CONTEXT *
4163 Perl_create_eval_scope(pTHX_ U32 flags)
4164 {
4165     PERL_CONTEXT *cx;
4166     const I32 gimme = GIMME_V;
4167
4168     ENTER_with_name("eval_scope");
4169     SAVETMPS;
4170
4171     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4172     PUSHEVAL(cx, 0);
4173
4174     PL_in_eval = EVAL_INEVAL;
4175     if (flags & G_KEEPERR)
4176         PL_in_eval |= EVAL_KEEPERR;
4177     else
4178         CLEAR_ERRSV();
4179     if (flags & G_FAKINGEVAL) {
4180         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4181     }
4182     return cx;
4183 }
4184
4185 PP(pp_entertry)
4186 {
4187     dVAR;
4188     PERL_CONTEXT * const cx = create_eval_scope(0);
4189     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4190     return DOCATCH(PL_op->op_next);
4191 }
4192
4193 PP(pp_leavetry)
4194 {
4195     dVAR; dSP;
4196     SV **newsp;
4197     PMOP *newpm;
4198     I32 gimme;
4199     register PERL_CONTEXT *cx;
4200     I32 optype;
4201
4202     PERL_ASYNC_CHECK();
4203     POPBLOCK(cx,newpm);
4204     POPEVAL(cx);
4205     PERL_UNUSED_VAR(optype);
4206
4207     TAINT_NOT;
4208     if (gimme == G_VOID)
4209         SP = newsp;
4210     else if (gimme == G_SCALAR) {
4211         register SV **mark;
4212         MARK = newsp + 1;
4213         if (MARK <= SP) {
4214             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4215                 *MARK = TOPs;
4216             else
4217                 *MARK = sv_mortalcopy(TOPs);
4218         }
4219         else {
4220             MEXTEND(mark,0);
4221             *MARK = &PL_sv_undef;
4222         }
4223         SP = MARK;
4224     }
4225     else {
4226         /* in case LEAVE wipes old return values */
4227         register SV **mark;
4228         for (mark = newsp + 1; mark <= SP; mark++) {
4229             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4230                 *mark = sv_mortalcopy(*mark);
4231                 TAINT_NOT;      /* Each item is independent */
4232             }
4233         }
4234     }
4235     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4236
4237     LEAVE_with_name("eval_scope");
4238     CLEAR_ERRSV();
4239     RETURN;
4240 }
4241
4242 PP(pp_entergiven)
4243 {
4244     dVAR; dSP;
4245     register PERL_CONTEXT *cx;
4246     const I32 gimme = GIMME_V;
4247
4248     ENTER_with_name("given");
4249     SAVETMPS;
4250
4251     sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4252
4253     PUSHBLOCK(cx, CXt_GIVEN, SP);
4254     PUSHGIVEN(cx);
4255
4256     RETURN;
4257 }
4258
4259 PP(pp_leavegiven)
4260 {
4261     dVAR; dSP;
4262     register PERL_CONTEXT *cx;
4263     I32 gimme;
4264     SV **newsp;
4265     PMOP *newpm;
4266     PERL_UNUSED_CONTEXT;
4267
4268     POPBLOCK(cx,newpm);
4269     assert(CxTYPE(cx) == CXt_GIVEN);
4270
4271     TAINT_NOT;
4272     if (gimme == G_VOID)
4273         SP = newsp;
4274     else if (gimme == G_SCALAR) {
4275         register SV **mark;
4276         MARK = newsp + 1;
4277         if (MARK <= SP) {
4278             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4279                 *MARK = TOPs;
4280             else
4281                 *MARK = sv_mortalcopy(TOPs);
4282         }
4283         else {
4284             MEXTEND(mark,0);
4285             *MARK = &PL_sv_undef;
4286         }
4287         SP = MARK;
4288     }
4289     else {
4290         /* in case LEAVE wipes old return values */
4291         register SV **mark;
4292         for (mark = newsp + 1; mark <= SP; mark++) {
4293             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4294                 *mark = sv_mortalcopy(*mark);
4295                 TAINT_NOT;      /* Each item is independent */
4296             }
4297         }
4298     }
4299     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4300
4301     LEAVE_with_name("given");
4302     RETURN;
4303 }
4304
4305 /* Helper routines used by pp_smartmatch */
4306 STATIC PMOP *
4307 S_make_matcher(pTHX_ REGEXP *re)
4308 {
4309     dVAR;
4310     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4311
4312     PERL_ARGS_ASSERT_MAKE_MATCHER;
4313
4314     PM_SETRE(matcher, ReREFCNT_inc(re));
4315
4316     SAVEFREEOP((OP *) matcher);
4317     ENTER_with_name("matcher"); SAVETMPS;
4318     SAVEOP();
4319     return matcher;
4320 }
4321
4322 STATIC bool
4323 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4324 {
4325     dVAR;
4326     dSP;
4327
4328     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4329
4330     PL_op = (OP *) matcher;
4331     XPUSHs(sv);
4332     PUTBACK;
4333     (void) Perl_pp_match(aTHX);
4334     SPAGAIN;
4335     return (SvTRUEx(POPs));
4336 }
4337
4338 STATIC void
4339 S_destroy_matcher(pTHX_ PMOP *matcher)
4340 {
4341     dVAR;
4342
4343     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4344     PERL_UNUSED_ARG(matcher);
4345
4346     FREETMPS;
4347     LEAVE_with_name("matcher");
4348 }
4349
4350 /* Do a smart match */
4351 PP(pp_smartmatch)
4352 {
4353     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4354     return do_smartmatch(NULL, NULL);
4355 }
4356
4357 /* This version of do_smartmatch() implements the
4358  * table of smart matches that is found in perlsyn.
4359  */
4360 STATIC OP *
4361 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4362 {
4363     dVAR;
4364     dSP;
4365
4366     bool object_on_left = FALSE;
4367     SV *e = TOPs;       /* e is for 'expression' */
4368     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4369
4370     /* Take care only to invoke mg_get() once for each argument.
4371      * Currently we do this by copying the SV if it's magical. */
4372     if (d) {
4373         if (SvGMAGICAL(d))
4374             d = sv_mortalcopy(d);
4375     }
4376     else
4377         d = &PL_sv_undef;
4378
4379     assert(e);
4380     if (SvGMAGICAL(e))
4381         e = sv_mortalcopy(e);
4382
4383     /* First of all, handle overload magic of the rightmost argument */
4384     if (SvAMAGIC(e)) {
4385         SV * tmpsv;
4386         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4387         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4388
4389         tmpsv = amagic_call(d, e, smart_amg, 0);
4390         if (tmpsv) {
4391             SPAGAIN;
4392             (void)POPs;
4393             SETs(tmpsv);
4394             RETURN;
4395         }
4396         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4397     }
4398
4399     SP -= 2;    /* Pop the values */
4400
4401
4402     /* ~~ undef */
4403     if (!SvOK(e)) {
4404         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4405         if (SvOK(d))
4406             RETPUSHNO;
4407         else
4408             RETPUSHYES;
4409     }
4410
4411     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4412         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4413         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4414     }
4415     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4416         object_on_left = TRUE;
4417
4418     /* ~~ sub */
4419     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4420         I32 c;
4421         if (object_on_left) {
4422             goto sm_any_sub; /* Treat objects like scalars */
4423         }
4424         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4425             /* Test sub truth for each key */
4426             HE *he;
4427             bool andedresults = TRUE;
4428             HV *hv = (HV*) SvRV(d);
4429             I32 numkeys = hv_iterinit(hv);
4430             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4431             if (numkeys == 0)
4432                 RETPUSHYES;
4433             while ( (he = hv_iternext(hv)) ) {
4434                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4435                 ENTER_with_name("smartmatch_hash_key_test");
4436                 SAVETMPS;
4437                 PUSHMARK(SP);
4438                 PUSHs(hv_iterkeysv(he));
4439                 PUTBACK;
4440                 c = call_sv(e, G_SCALAR);
4441                 SPAGAIN;
4442                 if (c == 0)
4443                     andedresults = FALSE;
4444                 else
4445                     andedresults = SvTRUEx(POPs) && andedresults;
4446                 FREETMPS;
4447                 LEAVE_with_name("smartmatch_hash_key_test");
4448             }
4449             if (andedresults)
4450                 RETPUSHYES;
4451             else
4452                 RETPUSHNO;
4453         }
4454         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4455             /* Test sub truth for each element */
4456             I32 i;
4457             bool andedresults = TRUE;
4458             AV *av = (AV*) SvRV(d);
4459             const I32 len = av_len(av);
4460             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4461             if (len == -1)
4462                 RETPUSHYES;
4463             for (i = 0; i <= len; ++i) {
4464                 SV * const * const svp = av_fetch(av, i, FALSE);
4465                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4466                 ENTER_with_name("smartmatch_array_elem_test");
4467                 SAVETMPS;
4468                 PUSHMARK(SP);
4469                 if (svp)
4470                     PUSHs(*svp);
4471                 PUTBACK;
4472                 c = call_sv(e, G_SCALAR);
4473                 SPAGAIN;
4474                 if (c == 0)
4475                     andedresults = FALSE;
4476                 else
4477                     andedresults = SvTRUEx(POPs) && andedresults;
4478                 FREETMPS;
4479                 LEAVE_with_name("smartmatch_array_elem_test");
4480             }
4481             if (andedresults)
4482                 RETPUSHYES;
4483             else
4484                 RETPUSHNO;
4485         }
4486         else {
4487           sm_any_sub:
4488             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4489             ENTER_with_name("smartmatch_coderef");
4490             SAVETMPS;
4491             PUSHMARK(SP);
4492             PUSHs(d);
4493             PUTBACK;
4494             c = call_sv(e, G_SCALAR);
4495             SPAGAIN;
4496             if (c == 0)
4497                 PUSHs(&PL_sv_no);
4498             else if (SvTEMP(TOPs))
4499                 SvREFCNT_inc_void(TOPs);
4500             FREETMPS;
4501             LEAVE_with_name("smartmatch_coderef");
4502             RETURN;
4503         }
4504     }
4505     /* ~~ %hash */
4506     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4507         if (object_on_left) {
4508             goto sm_any_hash; /* Treat objects like scalars */
4509         }
4510         else if (!SvOK(d)) {