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