pp_ctl.c

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