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