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