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