pp_ctl.c

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