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