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